From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- pkg/images/README | 10 + pkg/images/Revisions | 3680 ++++++++++++++++++++ pkg/images/images.cl | 38 + pkg/images/images.hd | 46 + pkg/images/images.men | 7 + pkg/images/images.par | 3 + pkg/images/imcoords/Revisions | 2026 +++++++++++ pkg/images/imcoords/ccfind.par | 48 + pkg/images/imcoords/ccget.par | 36 + pkg/images/imcoords/ccmap.par | 54 + pkg/images/imcoords/ccsetwcs.par | 28 + pkg/images/imcoords/ccstd.par | 31 + pkg/images/imcoords/cctran.par | 28 + pkg/images/imcoords/ccxymatch.par | 41 + pkg/images/imcoords/doc/ccfind.hlp | 596 ++++ pkg/images/imcoords/doc/ccget.hlp | 463 +++ pkg/images/imcoords/doc/ccmap.hlp | 1028 ++++++ pkg/images/imcoords/doc/ccsetwcs.hlp | 562 +++ pkg/images/imcoords/doc/ccstd.hlp | 480 +++ pkg/images/imcoords/doc/cctran.hlp | 412 +++ pkg/images/imcoords/doc/ccxymatch.hlp | 781 +++++ pkg/images/imcoords/doc/hpctran.hlp | 109 + pkg/images/imcoords/doc/imcctran.hlp | 598 ++++ pkg/images/imcoords/doc/mkcwcs.hlp | 93 + pkg/images/imcoords/doc/mkcwwcs.hlp | 110 + pkg/images/imcoords/doc/skyctran.hlp | 861 +++++ pkg/images/imcoords/doc/starfind.hlp | 304 ++ pkg/images/imcoords/doc/wcsctran.hlp | 340 ++ pkg/images/imcoords/doc/wcsedit.hlp | 429 +++ pkg/images/imcoords/doc/wcsreset.hlp | 272 ++ pkg/images/imcoords/hpctran.par | 9 + pkg/images/imcoords/imcctran.par | 9 + pkg/images/imcoords/imcoords.cl | 27 + pkg/images/imcoords/imcoords.hd | 23 + pkg/images/imcoords/imcoords.men | 16 + pkg/images/imcoords/imcoords.par | 1 + pkg/images/imcoords/mkpkg | 5 + pkg/images/imcoords/skyctran.par | 29 + pkg/images/imcoords/src/ccfunc.x | 639 ++++ pkg/images/imcoords/src/ccstd.x | 252 ++ pkg/images/imcoords/src/ccxytran.x | 740 ++++ pkg/images/imcoords/src/healpix.x | 492 +++ pkg/images/imcoords/src/mkcwcs.cl | 94 + pkg/images/imcoords/src/mkcwwcs.cl | 102 + pkg/images/imcoords/src/mkpkg | 47 + pkg/images/imcoords/src/rgstr.gx | 109 + pkg/images/imcoords/src/rgstr.x | 215 ++ pkg/images/imcoords/src/sfconvolve.x | 398 +++ pkg/images/imcoords/src/sffind.x | 739 ++++ pkg/images/imcoords/src/sftools.x | 68 + pkg/images/imcoords/src/skyctran.x | 2057 +++++++++++ pkg/images/imcoords/src/skycur.key | 38 + pkg/images/imcoords/src/starfind.h | 51 + pkg/images/imcoords/src/t_ccfind.x | 782 +++++ pkg/images/imcoords/src/t_ccget.x | 1201 +++++++ pkg/images/imcoords/src/t_ccmap.x | 2079 +++++++++++ pkg/images/imcoords/src/t_ccsetwcs.x | 751 ++++ pkg/images/imcoords/src/t_ccstd.x | 468 +++ pkg/images/imcoords/src/t_cctran.x | 374 ++ pkg/images/imcoords/src/t_ccxymatch.x | 576 +++ pkg/images/imcoords/src/t_hpctran.x | 136 + pkg/images/imcoords/src/t_imcctran.x | 922 +++++ pkg/images/imcoords/src/t_skyctran.x | 221 ++ pkg/images/imcoords/src/t_starfind.x | 224 ++ pkg/images/imcoords/src/t_wcsctran.x | 643 ++++ pkg/images/imcoords/src/t_wcsedit.x | 792 +++++ pkg/images/imcoords/src/t_wcsreset.x | 142 + pkg/images/imcoords/src/ttycur.key | 49 + pkg/images/imcoords/src/wcsedit.key | 24 + pkg/images/imcoords/src/x_starfind.x | 1 + pkg/images/imcoords/starfind.par | 25 + pkg/images/imcoords/wcsctran.par | 12 + pkg/images/imcoords/wcsedit.par | 13 + pkg/images/imcoords/wcsreset.par | 5 + pkg/images/imfilter/Revisions | 2025 +++++++++++ pkg/images/imfilter/boxcar.par | 9 + pkg/images/imfilter/convolve.par | 13 + pkg/images/imfilter/doc/boxcar.hlp | 70 + pkg/images/imfilter/doc/convolve.hlp | 167 + pkg/images/imfilter/doc/fmedian.hlp | 165 + pkg/images/imfilter/doc/fmode.hlp | 176 + pkg/images/imfilter/doc/frmedian.hlp | 191 + pkg/images/imfilter/doc/frmode.hlp | 197 ++ pkg/images/imfilter/doc/gauss.hlp | 162 + pkg/images/imfilter/doc/gradient.hlp | 170 + pkg/images/imfilter/doc/laplace.hlp | 132 + pkg/images/imfilter/doc/median.hlp | 109 + pkg/images/imfilter/doc/mode.hlp | 119 + pkg/images/imfilter/doc/rmedian.hlp | 127 + pkg/images/imfilter/doc/rmode.hlp | 133 + pkg/images/imfilter/doc/runmed.hlp | 206 ++ pkg/images/imfilter/fmedian.par | 17 + pkg/images/imfilter/fmode.par | 17 + pkg/images/imfilter/frmedian.par | 19 + pkg/images/imfilter/frmode.par | 19 + pkg/images/imfilter/gauss.par | 12 + pkg/images/imfilter/gradient.par | 8 + pkg/images/imfilter/imfilter.cl | 24 + pkg/images/imfilter/imfilter.hd | 21 + pkg/images/imfilter/imfilter.men | 14 + pkg/images/imfilter/imfilter.par | 1 + pkg/images/imfilter/laplace.par | 8 + pkg/images/imfilter/median.par | 12 + pkg/images/imfilter/mkpkg | 5 + pkg/images/imfilter/mode.par | 12 + pkg/images/imfilter/rmedian.par | 14 + pkg/images/imfilter/rmode.par | 14 + pkg/images/imfilter/runmed.par | 16 + pkg/images/imfilter/src/aboxcar.x | 24 + pkg/images/imfilter/src/boxcar.x | 89 + pkg/images/imfilter/src/convolve.x | 98 + pkg/images/imfilter/src/fmd_buf.x | 124 + pkg/images/imfilter/src/fmd_hist.x | 28 + pkg/images/imfilter/src/fmd_maxmin.x | 62 + pkg/images/imfilter/src/fmedian.h | 23 + pkg/images/imfilter/src/fmedian.x | 556 +++ pkg/images/imfilter/src/fmode.h | 24 + pkg/images/imfilter/src/fmode.x | 578 +++ pkg/images/imfilter/src/frmedian.h | 17 + pkg/images/imfilter/src/frmedian.x | 180 + pkg/images/imfilter/src/frmode.h | 17 + pkg/images/imfilter/src/frmode.x | 181 + pkg/images/imfilter/src/med_buf.x | 65 + pkg/images/imfilter/src/med_sort.x | 168 + pkg/images/imfilter/src/med_utils.x | 104 + pkg/images/imfilter/src/median.h | 15 + pkg/images/imfilter/src/median.x | 866 +++++ pkg/images/imfilter/src/mkpkg | 43 + pkg/images/imfilter/src/mode.h | 16 + pkg/images/imfilter/src/mode.x | 903 +++++ pkg/images/imfilter/src/radcnv.x | 95 + pkg/images/imfilter/src/rmedian.h | 9 + pkg/images/imfilter/src/rmedian.x | 126 + pkg/images/imfilter/src/rmode.h | 9 + pkg/images/imfilter/src/rmode.x | 131 + pkg/images/imfilter/src/runmed.x | 506 +++ pkg/images/imfilter/src/t_boxcar.x | 92 + pkg/images/imfilter/src/t_convolve.x | 302 ++ pkg/images/imfilter/src/t_fmedian.x | 148 + pkg/images/imfilter/src/t_fmode.x | 148 + pkg/images/imfilter/src/t_frmedian.x | 194 ++ pkg/images/imfilter/src/t_frmode.x | 194 ++ pkg/images/imfilter/src/t_gauss.x | 297 ++ pkg/images/imfilter/src/t_gradient.x | 245 ++ pkg/images/imfilter/src/t_laplace.x | 177 + pkg/images/imfilter/src/t_median.x | 126 + pkg/images/imfilter/src/t_mode.x | 125 + pkg/images/imfilter/src/t_rmedian.x | 179 + pkg/images/imfilter/src/t_rmode.x | 179 + pkg/images/imfilter/src/t_runmed.x | 62 + pkg/images/imfilter/src/xyconvolve.x | 124 + pkg/images/imfit/Revisions | 2025 +++++++++++ pkg/images/imfit/doc/fit1d.hlp | 177 + pkg/images/imfit/doc/imsurfit.hlp | 226 ++ pkg/images/imfit/doc/lineclean.hlp | 129 + pkg/images/imfit/fit1d.par | 16 + pkg/images/imfit/imfit.cl | 13 + pkg/images/imfit/imfit.hd | 10 + pkg/images/imfit/imfit.men | 3 + pkg/images/imfit/imfit.par | 1 + pkg/images/imfit/imsurfit.par | 24 + pkg/images/imfit/lineclean.par | 13 + pkg/images/imfit/mkpkg | 5 + pkg/images/imfit/src/fit1d.x | 597 ++++ pkg/images/imfit/src/imsurfit.h | 40 + pkg/images/imfit/src/imsurfit.x | 1172 +++++++ pkg/images/imfit/src/mkpkg | 15 + pkg/images/imfit/src/pixlist.h | 11 + pkg/images/imfit/src/pixlist.x | 369 ++ pkg/images/imfit/src/ranges.x | 524 +++ pkg/images/imfit/src/t_imsurfit.x | 400 +++ pkg/images/imfit/src/t_lineclean.x | 270 ++ pkg/images/imgeom/Revisions | 2026 +++++++++++ pkg/images/imgeom/blkavg.par | 12 + pkg/images/imgeom/blkrep.par | 11 + pkg/images/imgeom/doc/blkavg.hlp | 65 + pkg/images/imgeom/doc/blkrep.hlp | 103 + pkg/images/imgeom/doc/im3dtran.hlp | 94 + pkg/images/imgeom/doc/imlintran.hlp | 184 + pkg/images/imgeom/doc/imshift.hlp | 125 + pkg/images/imgeom/doc/imtrans.hlp | 69 + pkg/images/imgeom/doc/magnify.hlp | 202 ++ pkg/images/imgeom/doc/rotate.hlp | 164 + pkg/images/imgeom/doc/shiftlines.hlp | 119 + pkg/images/imgeom/im3dtran.par | 9 + pkg/images/imgeom/imgeom.cl | 30 + pkg/images/imgeom/imgeom.hd | 16 + pkg/images/imgeom/imgeom.men | 9 + pkg/images/imgeom/imgeom.par | 1 + pkg/images/imgeom/imlintran.cl | 50 + pkg/images/imgeom/imlintran.par | 30 + pkg/images/imgeom/imshift.par | 11 + pkg/images/imgeom/imtranspose.par | 3 + pkg/images/imgeom/junk.cl | 50 + pkg/images/imgeom/magnify.par | 17 + pkg/images/imgeom/mkpkg | 5 + pkg/images/imgeom/rotate.cl | 43 + pkg/images/imgeom/rotate.par | 24 + pkg/images/imgeom/shiftlines.par | 9 + pkg/images/imgeom/src/blkav.gx | 131 + pkg/images/imgeom/src/blkcomp.x | 38 + pkg/images/imgeom/src/blkrp.gx | 103 + pkg/images/imgeom/src/generic/blkav.x | 361 ++ pkg/images/imgeom/src/generic/blkrp.x | 397 +++ pkg/images/imgeom/src/generic/im3dtran.x | 583 ++++ pkg/images/imgeom/src/generic/imtrans.x | 93 + pkg/images/imgeom/src/generic/mkpkg | 13 + pkg/images/imgeom/src/im3dtran.gx | 98 + pkg/images/imgeom/src/imtrans.gx | 18 + pkg/images/imgeom/src/mkpkg | 35 + pkg/images/imgeom/src/shiftlines.x | 279 ++ pkg/images/imgeom/src/t_blkavg.x | 115 + pkg/images/imgeom/src/t_blkrep.x | 96 + pkg/images/imgeom/src/t_im3dtran.x | 719 ++++ pkg/images/imgeom/src/t_imshift.x | 530 +++ pkg/images/imgeom/src/t_imtrans.x | 299 ++ pkg/images/imgeom/src/t_magnify.x | 624 ++++ pkg/images/imgeom/src/t_shiftlines.x | 102 + pkg/images/immatch/Revisions | 2025 +++++++++++ pkg/images/immatch/doc/geomap.hlp | 435 +++ pkg/images/immatch/doc/geotran.hlp | 320 ++ pkg/images/immatch/doc/geoxytran.hlp | 408 +++ pkg/images/immatch/doc/gregister.hlp | 265 ++ pkg/images/immatch/doc/imalign.hlp | 316 ++ pkg/images/immatch/doc/imcentroid.hlp | 257 ++ pkg/images/immatch/doc/imcombine.hlp | 1471 ++++++++ pkg/images/immatch/doc/linmatch.hlp | 699 ++++ pkg/images/immatch/doc/psfmatch.hlp | 595 ++++ pkg/images/immatch/doc/skymap.hlp | 642 ++++ pkg/images/immatch/doc/skyxymatch.hlp | 406 +++ pkg/images/immatch/doc/sregister.hlp | 779 +++++ pkg/images/immatch/doc/wcscopy.hlp | 80 + pkg/images/immatch/doc/wcsmap.hlp | 619 ++++ pkg/images/immatch/doc/wcsxymatch.hlp | 314 ++ pkg/images/immatch/doc/wregister.hlp | 761 ++++ pkg/images/immatch/doc/xregister.hlp | 707 ++++ pkg/images/immatch/doc/xyxymatch.hlp | 468 +++ pkg/images/immatch/geomap.par | 32 + pkg/images/immatch/geotran.par | 45 + pkg/images/immatch/geoxytran.par | 28 + pkg/images/immatch/gregister.cl | 51 + pkg/images/immatch/gregister.par | 33 + pkg/images/immatch/imalign.cl | 119 + pkg/images/immatch/imalign.par | 28 + pkg/images/immatch/imcentroid.par | 16 + pkg/images/immatch/imcombine.par | 43 + pkg/images/immatch/immatch.cl | 39 + pkg/images/immatch/immatch.hd | 32 + pkg/images/immatch/immatch.men | 18 + pkg/images/immatch/immatch.par | 1 + pkg/images/immatch/linmatch.par | 30 + pkg/images/immatch/mkpkg | 5 + pkg/images/immatch/psfmatch.par | 40 + pkg/images/immatch/skymap.cl | 114 + pkg/images/immatch/skyxymatch.par | 26 + pkg/images/immatch/src/geometry/geofunc.gx | 250 ++ pkg/images/immatch/src/geometry/geofunc.x | 340 ++ pkg/images/immatch/src/geometry/geotimtran.x | 543 +++ pkg/images/immatch/src/geometry/geotran.h | 52 + pkg/images/immatch/src/geometry/geotran.x | 1752 ++++++++++ pkg/images/immatch/src/geometry/geoxytran.gx | 327 ++ pkg/images/immatch/src/geometry/geoxytran.x | 446 +++ pkg/images/immatch/src/geometry/mkpkg | 34 + pkg/images/immatch/src/geometry/t_geomap.gx | 921 +++++ pkg/images/immatch/src/geometry/t_geomap.x | 1509 ++++++++ pkg/images/immatch/src/geometry/t_geotran.x | 880 +++++ pkg/images/immatch/src/geometry/t_geoxytran.x | 343 ++ pkg/images/immatch/src/geometry/trinvert.x | 163 + pkg/images/immatch/src/imcombine/imcombine.par | 43 + pkg/images/immatch/src/imcombine/mkpkg | 20 + pkg/images/immatch/src/imcombine/src/Revisions | 36 + .../immatch/src/imcombine/src/generic/icaclip.x | 2207 ++++++++++++ .../immatch/src/imcombine/src/generic/icaverage.x | 424 +++ .../immatch/src/imcombine/src/generic/iccclip.x | 1791 ++++++++++ .../immatch/src/imcombine/src/generic/icgdata.x | 1531 ++++++++ .../immatch/src/imcombine/src/generic/icgrow.x | 263 ++ .../immatch/src/imcombine/src/generic/icmedian.x | 753 ++++ .../immatch/src/imcombine/src/generic/icmm.x | 645 ++++ .../immatch/src/imcombine/src/generic/icnmodel.x | 528 +++ .../immatch/src/imcombine/src/generic/icomb.x | 2198 ++++++++++++ .../immatch/src/imcombine/src/generic/icpclip.x | 879 +++++ .../immatch/src/imcombine/src/generic/icquad.x | 476 +++ .../immatch/src/imcombine/src/generic/icsclip.x | 1923 ++++++++++ .../immatch/src/imcombine/src/generic/icsigma.x | 434 +++ .../immatch/src/imcombine/src/generic/icsort.x | 1096 ++++++ .../immatch/src/imcombine/src/generic/icstat.x | 892 +++++ pkg/images/immatch/src/imcombine/src/generic/mkpkg | 27 + .../immatch/src/imcombine/src/generic/xtimmap.com | 9 + .../immatch/src/imcombine/src/generic/xtimmap.x | 1207 +++++++ pkg/images/immatch/src/imcombine/src/icaclip.gx | 575 +++ pkg/images/immatch/src/imcombine/src/icaverage.gx | 120 + pkg/images/immatch/src/imcombine/src/iccclip.gx | 471 +++ pkg/images/immatch/src/imcombine/src/icemask.x | 115 + pkg/images/immatch/src/imcombine/src/icgdata.gx | 396 +++ pkg/images/immatch/src/imcombine/src/icgrow.gx | 135 + pkg/images/immatch/src/imcombine/src/icgscale.x | 88 + pkg/images/immatch/src/imcombine/src/ichdr.x | 72 + pkg/images/immatch/src/imcombine/src/icimstack.x | 186 + pkg/images/immatch/src/imcombine/src/iclog.x | 431 +++ pkg/images/immatch/src/imcombine/src/icmask.com | 8 + pkg/images/immatch/src/imcombine/src/icmask.h | 12 + pkg/images/immatch/src/imcombine/src/icmask.x | 685 ++++ pkg/images/immatch/src/imcombine/src/icmedian.gx | 246 ++ pkg/images/immatch/src/imcombine/src/icmm.gx | 189 + pkg/images/immatch/src/imcombine/src/icnmodel.gx | 147 + pkg/images/immatch/src/imcombine/src/icomb.gx | 761 ++++ pkg/images/immatch/src/imcombine/src/icombine.com | 45 + pkg/images/immatch/src/imcombine/src/icombine.h | 63 + pkg/images/immatch/src/imcombine/src/icombine.x | 520 +++ pkg/images/immatch/src/imcombine/src/icpclip.gx | 233 ++ pkg/images/immatch/src/imcombine/src/icpmmap.x | 34 + pkg/images/immatch/src/imcombine/src/icquad.gx | 133 + pkg/images/immatch/src/imcombine/src/icrmasks.x | 41 + pkg/images/immatch/src/imcombine/src/icscale.x | 351 ++ pkg/images/immatch/src/imcombine/src/icsclip.gx | 504 +++ pkg/images/immatch/src/imcombine/src/icsection.x | 94 + pkg/images/immatch/src/imcombine/src/icsetout.x | 332 ++ pkg/images/immatch/src/imcombine/src/icsigma.gx | 122 + pkg/images/immatch/src/imcombine/src/icsort.gx | 386 ++ pkg/images/immatch/src/imcombine/src/icstat.gx | 238 ++ pkg/images/immatch/src/imcombine/src/mkpkg | 67 + pkg/images/immatch/src/imcombine/src/tymax.x | 27 + pkg/images/immatch/src/imcombine/src/xtimmap.gx | 634 ++++ pkg/images/immatch/src/imcombine/src/xtprocid.x | 38 + pkg/images/immatch/src/imcombine/t_imcombine.x | 230 ++ pkg/images/immatch/src/imcombine/x_imcombine.x | 1 + pkg/images/immatch/src/linmatch/linmatch.h | 298 ++ pkg/images/immatch/src/linmatch/linmatch.key | 51 + pkg/images/immatch/src/linmatch/lsqfit.h | 18 + pkg/images/immatch/src/linmatch/mkpkg | 21 + pkg/images/immatch/src/linmatch/rglcolon.x | 564 +++ pkg/images/immatch/src/linmatch/rgldbio.x | 225 ++ pkg/images/immatch/src/linmatch/rgldelete.x | 993 ++++++ pkg/images/immatch/src/linmatch/rgliscale.x | 593 ++++ pkg/images/immatch/src/linmatch/rglpars.x | 104 + pkg/images/immatch/src/linmatch/rglplot.x | 1592 +++++++++ pkg/images/immatch/src/linmatch/rglregions.x | 1084 ++++++ pkg/images/immatch/src/linmatch/rglscale.x | 1337 +++++++ pkg/images/immatch/src/linmatch/rglshow.x | 107 + pkg/images/immatch/src/linmatch/rglsqfit.x | 443 +++ pkg/images/immatch/src/linmatch/rgltools.x | 1017 ++++++ pkg/images/immatch/src/linmatch/t_linmatch.x | 544 +++ pkg/images/immatch/src/listmatch/mkpkg | 12 + pkg/images/immatch/src/listmatch/t_imctroid.x | 1016 ++++++ pkg/images/immatch/src/listmatch/t_xyxymatch.x | 406 +++ pkg/images/immatch/src/mkpkg | 11 + pkg/images/immatch/src/psfmatch/mkpkg | 21 + pkg/images/immatch/src/psfmatch/psfmatch.h | 274 ++ pkg/images/immatch/src/psfmatch/psfmatch.key | 50 + pkg/images/immatch/src/psfmatch/rgpbckgrd.x | 70 + pkg/images/immatch/src/psfmatch/rgpcolon.x | 501 +++ pkg/images/immatch/src/psfmatch/rgpconvolve.x | 106 + pkg/images/immatch/src/psfmatch/rgpfft.x | 443 +++ pkg/images/immatch/src/psfmatch/rgpfilter.x | 502 +++ pkg/images/immatch/src/psfmatch/rgpisfm.x | 556 +++ pkg/images/immatch/src/psfmatch/rgppars.x | 124 + pkg/images/immatch/src/psfmatch/rgpregions.x | 464 +++ pkg/images/immatch/src/psfmatch/rgpsfm.x | 815 +++++ pkg/images/immatch/src/psfmatch/rgpshow.x | 116 + pkg/images/immatch/src/psfmatch/rgptools.x | 641 ++++ pkg/images/immatch/src/psfmatch/t_psfmatch.x | 365 ++ pkg/images/immatch/src/wcsmatch/mkpkg | 14 + pkg/images/immatch/src/wcsmatch/rgmatchio.x | 77 + pkg/images/immatch/src/wcsmatch/t_skyxymatch.x | 690 ++++ pkg/images/immatch/src/wcsmatch/t_wcscopy.x | 199 ++ pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x | 787 +++++ pkg/images/immatch/src/wcsmatch/wcsxymatch.h | 15 + pkg/images/immatch/src/xregister/mkpkg | 25 + pkg/images/immatch/src/xregister/oxregister.key | 33 + pkg/images/immatch/src/xregister/rgxbckgrd.x | 63 + pkg/images/immatch/src/xregister/rgxcolon.x | 508 +++ pkg/images/immatch/src/xregister/rgxcorr.x | 1034 ++++++ pkg/images/immatch/src/xregister/rgxdbio.x | 290 ++ pkg/images/immatch/src/xregister/rgxfft.x | 179 + pkg/images/immatch/src/xregister/rgxfit.x | 814 +++++ pkg/images/immatch/src/xregister/rgxgpars.x | 68 + pkg/images/immatch/src/xregister/rgxicorr.x | 583 ++++ pkg/images/immatch/src/xregister/rgximshift.x | 391 +++ pkg/images/immatch/src/xregister/rgxplot.x | 317 ++ pkg/images/immatch/src/xregister/rgxppars.x | 49 + pkg/images/immatch/src/xregister/rgxregions.x | 459 +++ pkg/images/immatch/src/xregister/rgxshow.x | 172 + pkg/images/immatch/src/xregister/rgxtools.x | 685 ++++ pkg/images/immatch/src/xregister/rgxtransform.x | 446 +++ pkg/images/immatch/src/xregister/t_xregister.x | 440 +++ pkg/images/immatch/src/xregister/xregister.h | 250 ++ pkg/images/immatch/src/xregister/xregister.key | 47 + pkg/images/immatch/sregister.cl | 151 + pkg/images/immatch/wcscopy.par | 5 + pkg/images/immatch/wcsmap.cl | 111 + pkg/images/immatch/wcsxymatch.par | 25 + pkg/images/immatch/wregister.cl | 148 + pkg/images/immatch/xregister.par | 42 + pkg/images/immatch/xyxymatch.par | 36 + pkg/images/imutil/Revisions | 2045 +++++++++++ pkg/images/imutil/_imaxes.par | 9 + pkg/images/imutil/chpixtype.par | 8 + pkg/images/imutil/doc/chpix.hlp | 64 + pkg/images/imutil/doc/hedit.hlp | 375 ++ pkg/images/imutil/doc/hselect.hlp | 103 + pkg/images/imutil/doc/imarith.hlp | 218 ++ pkg/images/imutil/doc/imcopy.hlp | 91 + pkg/images/imutil/doc/imdelete.hlp | 55 + pkg/images/imutil/doc/imdivide.hlp | 65 + pkg/images/imutil/doc/imexpr.hlp | 447 +++ pkg/images/imutil/doc/imfunction.hlp | 130 + pkg/images/imutil/doc/imgets.hlp | 70 + pkg/images/imutil/doc/imheader.hlp | 62 + pkg/images/imutil/doc/imhistogram.hlp | 111 + pkg/images/imutil/doc/imjoin.hlp | 70 + pkg/images/imutil/doc/imrename.hlp | 50 + pkg/images/imutil/doc/imreplace.hlp | 72 + pkg/images/imutil/doc/imslice.hlp | 58 + pkg/images/imutil/doc/imstack.hlp | 56 + pkg/images/imutil/doc/imstat.hlp | 121 + pkg/images/imutil/doc/imsum.hlp | 132 + pkg/images/imutil/doc/imtile.hlp | 151 + pkg/images/imutil/doc/listpixels.hlp | 191 + pkg/images/imutil/doc/minmax.hlp | 84 + pkg/images/imutil/doc/nhedit.hlp | 499 +++ pkg/images/imutil/doc/sections.hlp | 119 + pkg/images/imutil/hedit.par | 9 + pkg/images/imutil/hselect.par | 4 + pkg/images/imutil/imarith.par | 11 + pkg/images/imutil/imcopy.par | 6 + pkg/images/imutil/imdelete.par | 7 + pkg/images/imutil/imdivide.par | 10 + pkg/images/imutil/imexpr.par | 44 + pkg/images/imutil/imfunction.par | 6 + pkg/images/imutil/imgets.par | 3 + pkg/images/imutil/imheader.par | 6 + pkg/images/imutil/imhistogram.par | 13 + pkg/images/imutil/imjoin.par | 5 + pkg/images/imutil/imrename.par | 3 + pkg/images/imutil/imreplace.par | 8 + pkg/images/imutil/imslice.par | 7 + pkg/images/imutil/imstack.par | 7 + pkg/images/imutil/imstatistics.par | 10 + pkg/images/imutil/imsum.par | 10 + pkg/images/imutil/imtile.par | 21 + pkg/images/imutil/imutil.cl | 35 + pkg/images/imutil/imutil.hd | 31 + pkg/images/imutil/imutil.men | 25 + pkg/images/imutil/imutil.par | 1 + pkg/images/imutil/listpixels.par | 4 + pkg/images/imutil/minmax.par | 10 + pkg/images/imutil/mkpkg | 5 + pkg/images/imutil/nhedit.par | 14 + pkg/images/imutil/sections.par | 5 + pkg/images/imutil/src/generic/imaadd.x | 255 ++ pkg/images/imutil/src/generic/imadiv.x | 347 ++ pkg/images/imutil/src/generic/imamax.x | 212 ++ pkg/images/imutil/src/generic/imamin.x | 212 ++ pkg/images/imutil/src/generic/imamul.x | 257 ++ pkg/images/imutil/src/generic/imanl.x | 159 + pkg/images/imutil/src/generic/imasub.x | 252 ++ pkg/images/imutil/src/generic/imfuncs.x | 1613 +++++++++ pkg/images/imutil/src/generic/imjoin.x | 527 +++ pkg/images/imutil/src/generic/imrep.x | 1423 ++++++++ pkg/images/imutil/src/generic/imsum.x | 1902 ++++++++++ pkg/images/imutil/src/generic/mkpkg | 21 + pkg/images/imutil/src/getcmd.x | 406 +++ pkg/images/imutil/src/gettok.h | 22 + pkg/images/imutil/src/gettok.x | 922 +++++ pkg/images/imutil/src/hedit.x | 806 +++++ pkg/images/imutil/src/hselect.x | 132 + pkg/images/imutil/src/iegsym.x | 37 + pkg/images/imutil/src/imaadd.gx | 55 + pkg/images/imutil/src/imadiv.gx | 75 + pkg/images/imutil/src/imamax.gx | 48 + pkg/images/imutil/src/imamin.gx | 48 + pkg/images/imutil/src/imamul.gx | 57 + pkg/images/imutil/src/imanl.gx | 47 + pkg/images/imutil/src/imasub.gx | 56 + pkg/images/imutil/src/imdelete.x | 85 + pkg/images/imutil/src/imexpr.gx | 1183 +++++++ pkg/images/imutil/src/imexpr.x | 1263 +++++++ pkg/images/imutil/src/imfuncs.gx | 786 +++++ pkg/images/imutil/src/imfunction.x | 306 ++ pkg/images/imutil/src/imgets.x | 53 + pkg/images/imutil/src/imheader.x | 303 ++ pkg/images/imutil/src/imhistogram.x | 332 ++ pkg/images/imutil/src/imjoin.gx | 92 + pkg/images/imutil/src/imminmax.x | 74 + pkg/images/imutil/src/imrep.gx | 346 ++ pkg/images/imutil/src/imstat.h | 62 + pkg/images/imutil/src/imsum.gx | 398 +++ pkg/images/imutil/src/imsum.h | 4 + pkg/images/imutil/src/imtile.h | 55 + pkg/images/imutil/src/listpixels.x | 216 ++ pkg/images/imutil/src/minmax.x | 313 ++ pkg/images/imutil/src/mkpkg | 81 + pkg/images/imutil/src/nhedit.x | 1101 ++++++ pkg/images/imutil/src/t_chpix.x | 238 ++ pkg/images/imutil/src/t_imarith.x | 489 +++ pkg/images/imutil/src/t_imaxes.x | 33 + pkg/images/imutil/src/t_imcopy.x | 82 + pkg/images/imutil/src/t_imdivide.x | 132 + pkg/images/imutil/src/t_imjoin.x | 272 ++ pkg/images/imutil/src/t_imrename.x | 100 + pkg/images/imutil/src/t_imreplace.x | 83 + pkg/images/imutil/src/t_imslice.x | 472 +++ pkg/images/imutil/src/t_imstack.x | 300 ++ pkg/images/imutil/src/t_imstat.x | 1213 +++++++ pkg/images/imutil/src/t_imsum.x | 320 ++ pkg/images/imutil/src/t_imtile.x | 619 ++++ pkg/images/imutil/src/t_minmax.x | 192 + pkg/images/imutil/src/t_sections.x | 39 + pkg/images/lib/coomap.key | 33 + pkg/images/lib/geofit.gx | 1605 +++++++++ pkg/images/lib/geofit.x | 2539 ++++++++++++++ pkg/images/lib/geofiti.x | 2521 ++++++++++++++ pkg/images/lib/geogmap.gx | 494 +++ pkg/images/lib/geogmap.h | 37 + pkg/images/lib/geogmap.x | 905 +++++ pkg/images/lib/geogmapi.x | 905 +++++ pkg/images/lib/geograph.gx | 1379 ++++++++ pkg/images/lib/geograph.x | 1740 +++++++++ pkg/images/lib/geomap.h | 109 + pkg/images/lib/geomap.key | 31 + pkg/images/lib/geoset.x | 61 + pkg/images/lib/imcopy.x | 106 + pkg/images/lib/liststr.gx | 427 +++ pkg/images/lib/liststr.x | 766 ++++ pkg/images/lib/mkpkg | 72 + pkg/images/lib/rgbckgrd.x | 661 ++++ pkg/images/lib/rgccwcs.x | 221 ++ pkg/images/lib/rgcontour.x | 475 +++ pkg/images/lib/rgfft.x | 269 ++ pkg/images/lib/rglltran.x | 42 + pkg/images/lib/rgmerge.x | 1023 ++++++ pkg/images/lib/rgsort.x | 162 + pkg/images/lib/rgtransform.x | 947 +++++ pkg/images/lib/rgwrdstr.x | 53 + pkg/images/lib/rgxymatch.x | 97 + pkg/images/lib/xymatch.x | 175 + pkg/images/lib/xyxymatch.h | 35 + pkg/images/lib/zzdebug.x | 430 +++ pkg/images/mkpkg | 33 + pkg/images/notes | 341 ++ pkg/images/tv/Revisions | 996 ++++++ pkg/images/tv/_dcontrol.par | 18 + pkg/images/tv/cimexam.par | 22 + pkg/images/tv/display.par | 30 + pkg/images/tv/display/README | 15 + pkg/images/tv/display/ace.h | 38 + pkg/images/tv/display/display.h | 42 + pkg/images/tv/display/dsmap.x | 33 + pkg/images/tv/display/dspmmap.x | 20 + pkg/images/tv/display/dsulut.x | 141 + pkg/images/tv/display/findz.x | 62 + pkg/images/tv/display/gwindow.h | 49 + pkg/images/tv/display/iis.com | 25 + pkg/images/tv/display/iis.h | 121 + pkg/images/tv/display/iisblk.x | 40 + pkg/images/tv/display/iiscls.x | 24 + pkg/images/tv/display/iisers.x | 28 + pkg/images/tv/display/iisflu.x | 24 + pkg/images/tv/display/iisgop.x | 14 + pkg/images/tv/display/iishdr.x | 30 + pkg/images/tv/display/iisio.x | 43 + pkg/images/tv/display/iismtc.x | 21 + pkg/images/tv/display/iisofm.x | 183 + pkg/images/tv/display/iisopn.x | 76 + pkg/images/tv/display/iispio.x | 97 + pkg/images/tv/display/iisrcr.x | 32 + pkg/images/tv/display/iisrd.x | 42 + pkg/images/tv/display/iisrgb.x | 32 + pkg/images/tv/display/iissfr.x | 15 + pkg/images/tv/display/iisstt.x | 29 + pkg/images/tv/display/iiswcr.x | 20 + pkg/images/tv/display/iiswnd.x | 117 + pkg/images/tv/display/iiswr.x | 48 + pkg/images/tv/display/iiswt.x | 19 + pkg/images/tv/display/iiszm.x | 38 + pkg/images/tv/display/imd.com | 7 + pkg/images/tv/display/imdgcur.x | 37 + pkg/images/tv/display/imdgetwcs.x | 188 + pkg/images/tv/display/imdmapfr.x | 108 + pkg/images/tv/display/imdmapping.x | 194 ++ pkg/images/tv/display/imdopen.x | 16 + pkg/images/tv/display/imdputwcs.x | 139 + pkg/images/tv/display/imdrcur.x | 117 + pkg/images/tv/display/imdrcuro.x | 206 ++ pkg/images/tv/display/imdsetwcs.x | 32 + pkg/images/tv/display/imdwcs.x | 118 + pkg/images/tv/display/imdwcsver.x | 65 + pkg/images/tv/display/maskcolor.x | 478 +++ pkg/images/tv/display/maxmin.x | 54 + pkg/images/tv/display/mkpkg | 79 + pkg/images/tv/display/sigl2.x | 976 ++++++ pkg/images/tv/display/sigm2.x | 1110 ++++++ pkg/images/tv/display/t_dcontrol.x | 193 + pkg/images/tv/display/t_display.x | 885 +++++ pkg/images/tv/display/zardim.x | 21 + pkg/images/tv/display/zawrim.x | 21 + pkg/images/tv/display/zawtim.x | 19 + pkg/images/tv/display/zblkim.x | 23 + pkg/images/tv/display/zclrim.x | 18 + pkg/images/tv/display/zclsim.x | 22 + pkg/images/tv/display/zdisplay.h | 6 + pkg/images/tv/display/zersim.x | 18 + pkg/images/tv/display/zfrmim.x | 19 + pkg/images/tv/display/zmapim.x | 19 + pkg/images/tv/display/zmtcim.x | 18 + pkg/images/tv/display/zopnim.x | 19 + pkg/images/tv/display/zrcrim.x | 19 + pkg/images/tv/display/zrgbim.x | 19 + pkg/images/tv/display/zrmim.x | 19 + pkg/images/tv/display/zscale.x | 623 ++++ pkg/images/tv/display/zsttim.x | 26 + pkg/images/tv/display/zwndim.x | 31 + pkg/images/tv/display/zzdebug.x | 165 + pkg/images/tv/doc/Tv.hlp | 357 ++ pkg/images/tv/doc/bpmedit.hlp | 155 + pkg/images/tv/doc/display.hlp | 555 +++ pkg/images/tv/doc/imedit.hlp | 493 +++ pkg/images/tv/doc/imexamine.hlp | 1043 ++++++ pkg/images/tv/doc/tvmark.hlp | 405 +++ pkg/images/tv/doc/wcslab.hlp | 698 ++++ pkg/images/tv/eimexam.par | 24 + pkg/images/tv/himexam.par | 29 + pkg/images/tv/iis/README | 3 + pkg/images/tv/iis/blink.cl | 19 + pkg/images/tv/iis/blink.par | 5 + pkg/images/tv/iis/cv.par | 4 + pkg/images/tv/iis/cvl.par | 25 + pkg/images/tv/iis/doc/Cv.spc.hlp | 286 ++ pkg/images/tv/iis/doc/blink.hlp | 46 + pkg/images/tv/iis/doc/cv.doc | 332 ++ pkg/images/tv/iis/doc/cv.hlp | 341 ++ pkg/images/tv/iis/doc/cv.ms | 332 ++ pkg/images/tv/iis/doc/cvl.hlp | 287 ++ pkg/images/tv/iis/doc/erase.hlp | 26 + pkg/images/tv/iis/doc/frame.hlp | 24 + pkg/images/tv/iis/doc/lumatch.hlp | 28 + pkg/images/tv/iis/doc/monochrome.hlp | 18 + pkg/images/tv/iis/doc/pseudocolor.hlp | 41 + pkg/images/tv/iis/doc/rgb.hlp | 33 + pkg/images/tv/iis/doc/window.hlp | 38 + pkg/images/tv/iis/doc/zoom.hlp | 31 + pkg/images/tv/iis/erase.cl | 10 + pkg/images/tv/iis/erase.par | 2 + pkg/images/tv/iis/frame.cl | 5 + pkg/images/tv/iis/giis.par | 7 + pkg/images/tv/iis/ids/doc/Imdis.hlp | 793 +++++ pkg/images/tv/iis/ids/doc/Note.misc | 8 + pkg/images/tv/iis/ids/doc/Note.pixel | 106 + pkg/images/tv/iis/ids/doc/file.doc | 90 + pkg/images/tv/iis/ids/doc/iis.doc | 172 + pkg/images/tv/iis/ids/font.com | 207 ++ pkg/images/tv/iis/ids/font.h | 29 + pkg/images/tv/iis/ids/idscancel.x | 19 + pkg/images/tv/iis/ids/idschars.x | 20 + pkg/images/tv/iis/ids/idsclear.x | 16 + pkg/images/tv/iis/ids/idsclose.x | 19 + pkg/images/tv/iis/ids/idsclosews.x | 15 + pkg/images/tv/iis/ids/idscround.x | 61 + pkg/images/tv/iis/ids/idsdrawch.x | 67 + pkg/images/tv/iis/ids/idsescape.x | 115 + pkg/images/tv/iis/ids/idsfa.x | 16 + pkg/images/tv/iis/ids/idsfaset.x | 18 + pkg/images/tv/iis/ids/idsflush.x | 18 + pkg/images/tv/iis/ids/idsfont.x | 40 + pkg/images/tv/iis/ids/idsgcell.x | 170 + pkg/images/tv/iis/ids/idsgcur.x | 33 + pkg/images/tv/iis/ids/idsinit.x | 172 + pkg/images/tv/iis/ids/idsline.x | 30 + pkg/images/tv/iis/ids/idslutfill.x | 36 + pkg/images/tv/iis/ids/idsopen.x | 58 + pkg/images/tv/iis/ids/idsopenws.x | 120 + pkg/images/tv/iis/ids/idspcell.x | 178 + pkg/images/tv/iis/ids/idspl.x | 61 + pkg/images/tv/iis/ids/idsplset.x | 21 + pkg/images/tv/iis/ids/idspm.x | 56 + pkg/images/tv/iis/ids/idspmset.x | 19 + pkg/images/tv/iis/ids/idspoint.x | 65 + pkg/images/tv/iis/ids/idsreset.x | 56 + pkg/images/tv/iis/ids/idsrestore.x | 84 + pkg/images/tv/iis/ids/idssave.x | 82 + pkg/images/tv/iis/ids/idsscur.x | 12 + pkg/images/tv/iis/ids/idsstream.x | 16 + pkg/images/tv/iis/ids/idstx.x | 428 +++ pkg/images/tv/iis/ids/idstxset.x | 30 + pkg/images/tv/iis/ids/idsvector.x | 122 + pkg/images/tv/iis/ids/mkpkg | 43 + pkg/images/tv/iis/ids/testcode/README | 2 + pkg/images/tv/iis/ids/testcode/box.x | 83 + pkg/images/tv/iis/ids/testcode/boxin.x | 98 + pkg/images/tv/iis/ids/testcode/crin.x | 130 + pkg/images/tv/iis/ids/testcode/grey.x | 90 + pkg/images/tv/iis/ids/testcode/grin.x | 98 + pkg/images/tv/iis/ids/testcode/scr.x | 130 + pkg/images/tv/iis/ids/testcode/scrin.x | 130 + pkg/images/tv/iis/ids/testcode/sn.x | 192 + pkg/images/tv/iis/ids/testcode/t_giis.x | 67 + pkg/images/tv/iis/ids/testcode/zm.x | 64 + pkg/images/tv/iis/ids/testcode/zmin.x | 84 + pkg/images/tv/iis/ids/testcode/zztest.x | 81 + pkg/images/tv/iis/iis.cl | 22 + pkg/images/tv/iis/iis.hd | 16 + pkg/images/tv/iis/iis.men | 11 + pkg/images/tv/iis/iis.par | 1 + pkg/images/tv/iis/iism70/README | 5 + pkg/images/tv/iis/iism70/idsexpand.x | 30 + pkg/images/tv/iis/iism70/iis.com | 12 + pkg/images/tv/iis/iism70/iis.h | 120 + pkg/images/tv/iis/iism70/iisbutton.x | 44 + pkg/images/tv/iis/iism70/iiscls.x | 27 + pkg/images/tv/iis/iism70/iiscursor.x | 108 + pkg/images/tv/iis/iism70/iishdr.x | 31 + pkg/images/tv/iis/iism70/iishisto.x | 53 + pkg/images/tv/iis/iism70/iisifm.x | 51 + pkg/images/tv/iis/iism70/iisio.x | 35 + pkg/images/tv/iis/iism70/iislut.x | 67 + pkg/images/tv/iis/iism70/iismatch.x | 76 + pkg/images/tv/iis/iism70/iisminmax.x | 87 + pkg/images/tv/iis/iism70/iisoffset.x | 67 + pkg/images/tv/iis/iism70/iisofm.x | 53 + pkg/images/tv/iis/iism70/iisopn.x | 35 + pkg/images/tv/iis/iism70/iispack.x | 21 + pkg/images/tv/iis/iism70/iispio.x | 65 + pkg/images/tv/iis/iism70/iisrange.x | 97 + pkg/images/tv/iis/iism70/iisrd.x | 51 + pkg/images/tv/iis/iism70/iisscroll.x | 101 + pkg/images/tv/iis/iism70/iissplit.x | 68 + pkg/images/tv/iis/iism70/iistball.x | 41 + pkg/images/tv/iis/iism70/iiswr.x | 51 + pkg/images/tv/iis/iism70/iiswt.x | 18 + pkg/images/tv/iis/iism70/iiszoom.x | 98 + pkg/images/tv/iis/iism70/mkpkg | 58 + pkg/images/tv/iis/iism70/zardim.x | 16 + pkg/images/tv/iis/iism70/zawrim.x | 14 + pkg/images/tv/iis/iism70/zawtim.x | 16 + pkg/images/tv/iis/iism70/zclear.x | 33 + pkg/images/tv/iis/iism70/zclsim.x | 13 + pkg/images/tv/iis/iism70/zcontrol.x | 116 + pkg/images/tv/iis/iism70/zcursor_read.x | 96 + pkg/images/tv/iis/iism70/zcursor_set.x | 100 + pkg/images/tv/iis/iism70/zdisplay_g.x | 91 + pkg/images/tv/iis/iism70/zdisplay_i.x | 124 + pkg/images/tv/iis/iism70/zinit.x | 45 + pkg/images/tv/iis/iism70/zopnim.x | 17 + pkg/images/tv/iis/iism70/zreset.x | 164 + pkg/images/tv/iis/iism70/zrestore.x | 30 + pkg/images/tv/iis/iism70/zsave.x | 30 + pkg/images/tv/iis/iism70/zseek.x | 21 + pkg/images/tv/iis/iism70/zsetup.x | 34 + pkg/images/tv/iis/iism70/zsnap.com | 26 + pkg/images/tv/iis/iism70/zsnap.x | 239 ++ pkg/images/tv/iis/iism70/zsnapinit.x | 314 ++ pkg/images/tv/iis/iism70/zsttim.x | 14 + pkg/images/tv/iis/lib/ids.com | 25 + pkg/images/tv/iis/lib/ids.h | 175 + pkg/images/tv/iis/lumatch.cl | 8 + pkg/images/tv/iis/lumatch.par | 2 + pkg/images/tv/iis/mkpkg | 25 + pkg/images/tv/iis/monochrome.cl | 5 + pkg/images/tv/iis/pseudocolor.cl | 24 + pkg/images/tv/iis/pseudocolor.par | 7 + pkg/images/tv/iis/rgb.cl | 11 + pkg/images/tv/iis/rgb.par | 4 + pkg/images/tv/iis/src/blink.x | 132 + pkg/images/tv/iis/src/clear.x | 48 + pkg/images/tv/iis/src/cv.com | 16 + pkg/images/tv/iis/src/cv.h | 51 + pkg/images/tv/iis/src/cv.x | 175 + pkg/images/tv/iis/src/cvparse.x | 196 ++ pkg/images/tv/iis/src/cvulut.x | 130 + pkg/images/tv/iis/src/cvutil.x | 538 +++ pkg/images/tv/iis/src/display.x | 104 + pkg/images/tv/iis/src/gwindow.h | 34 + pkg/images/tv/iis/src/load1.x | 324 ++ pkg/images/tv/iis/src/load2.x | 335 ++ pkg/images/tv/iis/src/map.x | 320 ++ pkg/images/tv/iis/src/match.x | 172 + pkg/images/tv/iis/src/maxmin.x | 52 + pkg/images/tv/iis/src/mkpkg | 39 + pkg/images/tv/iis/src/offset.x | 53 + pkg/images/tv/iis/src/pan.x | 99 + pkg/images/tv/iis/src/range.x | 57 + pkg/images/tv/iis/src/rdcur.x | 111 + pkg/images/tv/iis/src/reset.x | 37 + pkg/images/tv/iis/src/sigl2.x | 677 ++++ pkg/images/tv/iis/src/snap.x | 64 + pkg/images/tv/iis/src/split.x | 95 + pkg/images/tv/iis/src/tell.x | 24 + pkg/images/tv/iis/src/text.x | 71 + pkg/images/tv/iis/src/window.x | 181 + pkg/images/tv/iis/src/zoom.x | 60 + pkg/images/tv/iis/src/zscale.x | 457 +++ pkg/images/tv/iis/window.cl | 5 + pkg/images/tv/iis/x_iis.x | 7 + pkg/images/tv/iis/zoom.cl | 11 + pkg/images/tv/iis/zoom.par | 2 + pkg/images/tv/imedit.par | 24 + pkg/images/tv/imedit/bpmedit.cl | 69 + pkg/images/tv/imedit/bpmedit.key | 51 + pkg/images/tv/imedit/epbackground.x | 71 + pkg/images/tv/imedit/epcol.x | 80 + pkg/images/tv/imedit/epcolon.x | 335 ++ pkg/images/tv/imedit/epconstant.x | 51 + pkg/images/tv/imedit/epdisplay.x | 196 ++ pkg/images/tv/imedit/epdosurface.x | 35 + pkg/images/tv/imedit/epgcur.x | 127 + pkg/images/tv/imedit/epgdata.x | 70 + pkg/images/tv/imedit/epgsfit.x | 74 + pkg/images/tv/imedit/epimcopy.x | 72 + pkg/images/tv/imedit/epinput.x | 55 + pkg/images/tv/imedit/epix.h | 50 + pkg/images/tv/imedit/epline.x | 80 + pkg/images/tv/imedit/epmask.x | 177 + pkg/images/tv/imedit/epmove.x | 129 + pkg/images/tv/imedit/epnoise.x | 95 + pkg/images/tv/imedit/epreplace.gx | 167 + pkg/images/tv/imedit/epreplace.x | 260 ++ pkg/images/tv/imedit/epsearch.x | 90 + pkg/images/tv/imedit/epsetpars.x | 75 + pkg/images/tv/imedit/epstatistics.x | 147 + pkg/images/tv/imedit/epsurface.x | 46 + pkg/images/tv/imedit/imedit.key | 84 + pkg/images/tv/imedit/mkpkg | 38 + pkg/images/tv/imedit/t_imedit.x | 305 ++ pkg/images/tv/imexamine.par | 22 + pkg/images/tv/imexamine/iecimexam.x | 81 + pkg/images/tv/imexamine/iecolon.x | 1038 ++++++ pkg/images/tv/imexamine/iedisplay.x | 55 + pkg/images/tv/imexamine/ieeimexam.x | 243 ++ pkg/images/tv/imexamine/iegcur.x | 242 ++ pkg/images/tv/imexamine/iegdata.x | 45 + pkg/images/tv/imexamine/iegimage.x | 261 ++ pkg/images/tv/imexamine/iegnfr.x | 61 + pkg/images/tv/imexamine/iegraph.x | 145 + pkg/images/tv/imexamine/iehimexam.x | 193 + pkg/images/tv/imexamine/ieimname.x | 33 + pkg/images/tv/imexamine/iejimexam.x | 473 +++ pkg/images/tv/imexamine/ielimexam.x | 81 + pkg/images/tv/imexamine/iemw.x | 191 + pkg/images/tv/imexamine/ieopenlog.x | 39 + pkg/images/tv/imexamine/iepos.x | 180 + pkg/images/tv/imexamine/ieprint.x | 67 + pkg/images/tv/imexamine/ieqrimexam.x | 489 +++ pkg/images/tv/imexamine/ierimexam.x | 752 ++++ pkg/images/tv/imexamine/iesimexam.x | 492 +++ pkg/images/tv/imexamine/iestatistics.x | 84 + pkg/images/tv/imexamine/ietimexam.x | 121 + pkg/images/tv/imexamine/ievimexam.x | 582 ++++ pkg/images/tv/imexamine/imexam.h | 55 + pkg/images/tv/imexamine/imexamine.par | 22 + pkg/images/tv/imexamine/mkpkg | 48 + pkg/images/tv/imexamine/starfocus.h | 140 + pkg/images/tv/imexamine/stfmeasure.x | 147 + pkg/images/tv/imexamine/stfprofile.x | 1189 +++++++ pkg/images/tv/imexamine/t_imexam.x | 352 ++ pkg/images/tv/imexamine/x_imexam.x | 1 + pkg/images/tv/jimexam.par | 29 + pkg/images/tv/kimexam.par | 29 + pkg/images/tv/limexam.par | 22 + pkg/images/tv/mkpkg | 37 + pkg/images/tv/rimexam.par | 35 + pkg/images/tv/simexam.par | 10 + pkg/images/tv/tv.cl | 43 + pkg/images/tv/tv.hd | 23 + pkg/images/tv/tv.men | 7 + pkg/images/tv/tv.par | 1 + pkg/images/tv/tvmark.par | 23 + pkg/images/tv/tvmark/asciilook.inc | 19 + pkg/images/tv/tvmark/mkbmark.x | 561 +++ pkg/images/tv/tvmark/mkcolon.x | 394 +++ pkg/images/tv/tvmark/mkfind.x | 52 + pkg/images/tv/tvmark/mkgmarks.x | 214 ++ pkg/images/tv/tvmark/mkgpars.x | 65 + pkg/images/tv/tvmark/mkgscur.x | 87 + pkg/images/tv/tvmark/mkmag.x | 20 + pkg/images/tv/tvmark/mkmark.x | 482 +++ pkg/images/tv/tvmark/mknew.x | 42 + pkg/images/tv/tvmark/mkonemark.x | 392 +++ pkg/images/tv/tvmark/mkoutname.x | 273 ++ pkg/images/tv/tvmark/mkpkg | 27 + pkg/images/tv/tvmark/mkppars.x | 40 + pkg/images/tv/tvmark/mkremove.x | 98 + pkg/images/tv/tvmark/mkshow.x | 95 + pkg/images/tv/tvmark/mktext.x | 164 + pkg/images/tv/tvmark/mktools.x | 505 +++ pkg/images/tv/tvmark/pixelfont.inc | 519 +++ pkg/images/tv/tvmark/t_tvmark.x | 267 ++ pkg/images/tv/tvmark/tvmark.h | 165 + pkg/images/tv/vimexam.par | 24 + pkg/images/tv/wcslab.par | 15 + pkg/images/tv/wcslab/mkpkg | 24 + pkg/images/tv/wcslab/t_wcslab.x | 137 + pkg/images/tv/wcslab/wcs_desc.h | 219 ++ pkg/images/tv/wcslab/wcslab.h | 98 + pkg/images/tv/wcslab/wcslab.x | 940 +++++ pkg/images/tv/wcslab/wlgrid.x | 448 +++ pkg/images/tv/wcslab/wllabel.x | 1077 ++++++ pkg/images/tv/wcslab/wlsetup.x | 1000 ++++++ pkg/images/tv/wcslab/wlutil.x | 390 +++ pkg/images/tv/wcslab/wlwcslab.x | 181 + pkg/images/tv/wcslab/zz.x | 23 + pkg/images/tv/wcspars.par | 19 + pkg/images/tv/wlpars.par | 45 + pkg/images/tv/x_tv.x | 10 + pkg/images/x_images.x | 80 + 904 files changed, 219862 insertions(+) create mode 100644 pkg/images/README create mode 100644 pkg/images/Revisions create mode 100644 pkg/images/images.cl create mode 100644 pkg/images/images.hd create mode 100644 pkg/images/images.men create mode 100644 pkg/images/images.par create mode 100644 pkg/images/imcoords/Revisions create mode 100644 pkg/images/imcoords/ccfind.par create mode 100644 pkg/images/imcoords/ccget.par create mode 100644 pkg/images/imcoords/ccmap.par create mode 100644 pkg/images/imcoords/ccsetwcs.par create mode 100644 pkg/images/imcoords/ccstd.par create mode 100644 pkg/images/imcoords/cctran.par create mode 100644 pkg/images/imcoords/ccxymatch.par create mode 100644 pkg/images/imcoords/doc/ccfind.hlp create mode 100644 pkg/images/imcoords/doc/ccget.hlp create mode 100644 pkg/images/imcoords/doc/ccmap.hlp create mode 100644 pkg/images/imcoords/doc/ccsetwcs.hlp create mode 100644 pkg/images/imcoords/doc/ccstd.hlp create mode 100644 pkg/images/imcoords/doc/cctran.hlp create mode 100644 pkg/images/imcoords/doc/ccxymatch.hlp create mode 100644 pkg/images/imcoords/doc/hpctran.hlp create mode 100644 pkg/images/imcoords/doc/imcctran.hlp create mode 100644 pkg/images/imcoords/doc/mkcwcs.hlp create mode 100644 pkg/images/imcoords/doc/mkcwwcs.hlp create mode 100644 pkg/images/imcoords/doc/skyctran.hlp create mode 100644 pkg/images/imcoords/doc/starfind.hlp create mode 100644 pkg/images/imcoords/doc/wcsctran.hlp create mode 100644 pkg/images/imcoords/doc/wcsedit.hlp create mode 100644 pkg/images/imcoords/doc/wcsreset.hlp create mode 100644 pkg/images/imcoords/hpctran.par create mode 100644 pkg/images/imcoords/imcctran.par create mode 100644 pkg/images/imcoords/imcoords.cl create mode 100644 pkg/images/imcoords/imcoords.hd create mode 100644 pkg/images/imcoords/imcoords.men create mode 100644 pkg/images/imcoords/imcoords.par create mode 100644 pkg/images/imcoords/mkpkg create mode 100644 pkg/images/imcoords/skyctran.par create mode 100644 pkg/images/imcoords/src/ccfunc.x create mode 100644 pkg/images/imcoords/src/ccstd.x create mode 100644 pkg/images/imcoords/src/ccxytran.x create mode 100644 pkg/images/imcoords/src/healpix.x create mode 100644 pkg/images/imcoords/src/mkcwcs.cl create mode 100644 pkg/images/imcoords/src/mkcwwcs.cl create mode 100644 pkg/images/imcoords/src/mkpkg create mode 100644 pkg/images/imcoords/src/rgstr.gx create mode 100644 pkg/images/imcoords/src/rgstr.x create mode 100644 pkg/images/imcoords/src/sfconvolve.x create mode 100644 pkg/images/imcoords/src/sffind.x create mode 100644 pkg/images/imcoords/src/sftools.x create mode 100644 pkg/images/imcoords/src/skyctran.x create mode 100644 pkg/images/imcoords/src/skycur.key create mode 100644 pkg/images/imcoords/src/starfind.h create mode 100644 pkg/images/imcoords/src/t_ccfind.x create mode 100644 pkg/images/imcoords/src/t_ccget.x create mode 100644 pkg/images/imcoords/src/t_ccmap.x create mode 100644 pkg/images/imcoords/src/t_ccsetwcs.x create mode 100644 pkg/images/imcoords/src/t_ccstd.x create mode 100644 pkg/images/imcoords/src/t_cctran.x create mode 100644 pkg/images/imcoords/src/t_ccxymatch.x create mode 100644 pkg/images/imcoords/src/t_hpctran.x create mode 100644 pkg/images/imcoords/src/t_imcctran.x create mode 100644 pkg/images/imcoords/src/t_skyctran.x create mode 100644 pkg/images/imcoords/src/t_starfind.x create mode 100644 pkg/images/imcoords/src/t_wcsctran.x create mode 100644 pkg/images/imcoords/src/t_wcsedit.x create mode 100644 pkg/images/imcoords/src/t_wcsreset.x create mode 100644 pkg/images/imcoords/src/ttycur.key create mode 100644 pkg/images/imcoords/src/wcsedit.key create mode 100644 pkg/images/imcoords/src/x_starfind.x create mode 100644 pkg/images/imcoords/starfind.par create mode 100644 pkg/images/imcoords/wcsctran.par create mode 100644 pkg/images/imcoords/wcsedit.par create mode 100644 pkg/images/imcoords/wcsreset.par create mode 100644 pkg/images/imfilter/Revisions create mode 100644 pkg/images/imfilter/boxcar.par create mode 100644 pkg/images/imfilter/convolve.par create mode 100644 pkg/images/imfilter/doc/boxcar.hlp create mode 100644 pkg/images/imfilter/doc/convolve.hlp create mode 100644 pkg/images/imfilter/doc/fmedian.hlp create mode 100644 pkg/images/imfilter/doc/fmode.hlp create mode 100644 pkg/images/imfilter/doc/frmedian.hlp create mode 100644 pkg/images/imfilter/doc/frmode.hlp create mode 100644 pkg/images/imfilter/doc/gauss.hlp create mode 100644 pkg/images/imfilter/doc/gradient.hlp create mode 100644 pkg/images/imfilter/doc/laplace.hlp create mode 100644 pkg/images/imfilter/doc/median.hlp create mode 100644 pkg/images/imfilter/doc/mode.hlp create mode 100644 pkg/images/imfilter/doc/rmedian.hlp create mode 100644 pkg/images/imfilter/doc/rmode.hlp create mode 100644 pkg/images/imfilter/doc/runmed.hlp create mode 100644 pkg/images/imfilter/fmedian.par create mode 100644 pkg/images/imfilter/fmode.par create mode 100644 pkg/images/imfilter/frmedian.par create mode 100644 pkg/images/imfilter/frmode.par create mode 100644 pkg/images/imfilter/gauss.par create mode 100644 pkg/images/imfilter/gradient.par create mode 100644 pkg/images/imfilter/imfilter.cl create mode 100644 pkg/images/imfilter/imfilter.hd create mode 100644 pkg/images/imfilter/imfilter.men create mode 100644 pkg/images/imfilter/imfilter.par create mode 100644 pkg/images/imfilter/laplace.par create mode 100644 pkg/images/imfilter/median.par create mode 100644 pkg/images/imfilter/mkpkg create mode 100644 pkg/images/imfilter/mode.par create mode 100644 pkg/images/imfilter/rmedian.par create mode 100644 pkg/images/imfilter/rmode.par create mode 100644 pkg/images/imfilter/runmed.par create mode 100644 pkg/images/imfilter/src/aboxcar.x create mode 100644 pkg/images/imfilter/src/boxcar.x create mode 100644 pkg/images/imfilter/src/convolve.x create mode 100644 pkg/images/imfilter/src/fmd_buf.x create mode 100644 pkg/images/imfilter/src/fmd_hist.x create mode 100644 pkg/images/imfilter/src/fmd_maxmin.x create mode 100644 pkg/images/imfilter/src/fmedian.h create mode 100644 pkg/images/imfilter/src/fmedian.x create mode 100644 pkg/images/imfilter/src/fmode.h create mode 100644 pkg/images/imfilter/src/fmode.x create mode 100644 pkg/images/imfilter/src/frmedian.h create mode 100644 pkg/images/imfilter/src/frmedian.x create mode 100644 pkg/images/imfilter/src/frmode.h create mode 100644 pkg/images/imfilter/src/frmode.x create mode 100644 pkg/images/imfilter/src/med_buf.x create mode 100644 pkg/images/imfilter/src/med_sort.x create mode 100644 pkg/images/imfilter/src/med_utils.x create mode 100644 pkg/images/imfilter/src/median.h create mode 100644 pkg/images/imfilter/src/median.x create mode 100644 pkg/images/imfilter/src/mkpkg create mode 100644 pkg/images/imfilter/src/mode.h create mode 100644 pkg/images/imfilter/src/mode.x create mode 100644 pkg/images/imfilter/src/radcnv.x create mode 100644 pkg/images/imfilter/src/rmedian.h create mode 100644 pkg/images/imfilter/src/rmedian.x create mode 100644 pkg/images/imfilter/src/rmode.h create mode 100644 pkg/images/imfilter/src/rmode.x create mode 100644 pkg/images/imfilter/src/runmed.x create mode 100644 pkg/images/imfilter/src/t_boxcar.x create mode 100644 pkg/images/imfilter/src/t_convolve.x create mode 100644 pkg/images/imfilter/src/t_fmedian.x create mode 100644 pkg/images/imfilter/src/t_fmode.x create mode 100644 pkg/images/imfilter/src/t_frmedian.x create mode 100644 pkg/images/imfilter/src/t_frmode.x create mode 100644 pkg/images/imfilter/src/t_gauss.x create mode 100644 pkg/images/imfilter/src/t_gradient.x create mode 100644 pkg/images/imfilter/src/t_laplace.x create mode 100644 pkg/images/imfilter/src/t_median.x create mode 100644 pkg/images/imfilter/src/t_mode.x create mode 100644 pkg/images/imfilter/src/t_rmedian.x create mode 100644 pkg/images/imfilter/src/t_rmode.x create mode 100644 pkg/images/imfilter/src/t_runmed.x create mode 100644 pkg/images/imfilter/src/xyconvolve.x create mode 100644 pkg/images/imfit/Revisions create mode 100644 pkg/images/imfit/doc/fit1d.hlp create mode 100644 pkg/images/imfit/doc/imsurfit.hlp create mode 100644 pkg/images/imfit/doc/lineclean.hlp create mode 100644 pkg/images/imfit/fit1d.par create mode 100644 pkg/images/imfit/imfit.cl create mode 100644 pkg/images/imfit/imfit.hd create mode 100644 pkg/images/imfit/imfit.men create mode 100644 pkg/images/imfit/imfit.par create mode 100644 pkg/images/imfit/imsurfit.par create mode 100644 pkg/images/imfit/lineclean.par create mode 100644 pkg/images/imfit/mkpkg create mode 100644 pkg/images/imfit/src/fit1d.x create mode 100644 pkg/images/imfit/src/imsurfit.h create mode 100644 pkg/images/imfit/src/imsurfit.x create mode 100644 pkg/images/imfit/src/mkpkg create mode 100644 pkg/images/imfit/src/pixlist.h create mode 100644 pkg/images/imfit/src/pixlist.x create mode 100644 pkg/images/imfit/src/ranges.x create mode 100644 pkg/images/imfit/src/t_imsurfit.x create mode 100644 pkg/images/imfit/src/t_lineclean.x create mode 100644 pkg/images/imgeom/Revisions create mode 100644 pkg/images/imgeom/blkavg.par create mode 100644 pkg/images/imgeom/blkrep.par create mode 100644 pkg/images/imgeom/doc/blkavg.hlp create mode 100644 pkg/images/imgeom/doc/blkrep.hlp create mode 100644 pkg/images/imgeom/doc/im3dtran.hlp create mode 100644 pkg/images/imgeom/doc/imlintran.hlp create mode 100644 pkg/images/imgeom/doc/imshift.hlp create mode 100644 pkg/images/imgeom/doc/imtrans.hlp create mode 100644 pkg/images/imgeom/doc/magnify.hlp create mode 100644 pkg/images/imgeom/doc/rotate.hlp create mode 100644 pkg/images/imgeom/doc/shiftlines.hlp create mode 100644 pkg/images/imgeom/im3dtran.par create mode 100644 pkg/images/imgeom/imgeom.cl create mode 100644 pkg/images/imgeom/imgeom.hd create mode 100644 pkg/images/imgeom/imgeom.men create mode 100644 pkg/images/imgeom/imgeom.par create mode 100644 pkg/images/imgeom/imlintran.cl create mode 100644 pkg/images/imgeom/imlintran.par create mode 100644 pkg/images/imgeom/imshift.par create mode 100644 pkg/images/imgeom/imtranspose.par create mode 100644 pkg/images/imgeom/junk.cl create mode 100644 pkg/images/imgeom/magnify.par create mode 100644 pkg/images/imgeom/mkpkg create mode 100644 pkg/images/imgeom/rotate.cl create mode 100644 pkg/images/imgeom/rotate.par create mode 100644 pkg/images/imgeom/shiftlines.par create mode 100644 pkg/images/imgeom/src/blkav.gx create mode 100644 pkg/images/imgeom/src/blkcomp.x create mode 100644 pkg/images/imgeom/src/blkrp.gx create mode 100644 pkg/images/imgeom/src/generic/blkav.x create mode 100644 pkg/images/imgeom/src/generic/blkrp.x create mode 100644 pkg/images/imgeom/src/generic/im3dtran.x create mode 100644 pkg/images/imgeom/src/generic/imtrans.x create mode 100644 pkg/images/imgeom/src/generic/mkpkg create mode 100644 pkg/images/imgeom/src/im3dtran.gx create mode 100644 pkg/images/imgeom/src/imtrans.gx create mode 100644 pkg/images/imgeom/src/mkpkg create mode 100644 pkg/images/imgeom/src/shiftlines.x create mode 100644 pkg/images/imgeom/src/t_blkavg.x create mode 100644 pkg/images/imgeom/src/t_blkrep.x create mode 100644 pkg/images/imgeom/src/t_im3dtran.x create mode 100644 pkg/images/imgeom/src/t_imshift.x create mode 100644 pkg/images/imgeom/src/t_imtrans.x create mode 100644 pkg/images/imgeom/src/t_magnify.x create mode 100644 pkg/images/imgeom/src/t_shiftlines.x create mode 100644 pkg/images/immatch/Revisions create mode 100644 pkg/images/immatch/doc/geomap.hlp create mode 100644 pkg/images/immatch/doc/geotran.hlp create mode 100644 pkg/images/immatch/doc/geoxytran.hlp create mode 100644 pkg/images/immatch/doc/gregister.hlp create mode 100644 pkg/images/immatch/doc/imalign.hlp create mode 100644 pkg/images/immatch/doc/imcentroid.hlp create mode 100644 pkg/images/immatch/doc/imcombine.hlp create mode 100644 pkg/images/immatch/doc/linmatch.hlp create mode 100644 pkg/images/immatch/doc/psfmatch.hlp create mode 100644 pkg/images/immatch/doc/skymap.hlp create mode 100644 pkg/images/immatch/doc/skyxymatch.hlp create mode 100644 pkg/images/immatch/doc/sregister.hlp create mode 100644 pkg/images/immatch/doc/wcscopy.hlp create mode 100644 pkg/images/immatch/doc/wcsmap.hlp create mode 100644 pkg/images/immatch/doc/wcsxymatch.hlp create mode 100644 pkg/images/immatch/doc/wregister.hlp create mode 100644 pkg/images/immatch/doc/xregister.hlp create mode 100644 pkg/images/immatch/doc/xyxymatch.hlp create mode 100644 pkg/images/immatch/geomap.par create mode 100644 pkg/images/immatch/geotran.par create mode 100644 pkg/images/immatch/geoxytran.par create mode 100644 pkg/images/immatch/gregister.cl create mode 100644 pkg/images/immatch/gregister.par create mode 100644 pkg/images/immatch/imalign.cl create mode 100644 pkg/images/immatch/imalign.par create mode 100644 pkg/images/immatch/imcentroid.par create mode 100644 pkg/images/immatch/imcombine.par create mode 100644 pkg/images/immatch/immatch.cl create mode 100644 pkg/images/immatch/immatch.hd create mode 100644 pkg/images/immatch/immatch.men create mode 100644 pkg/images/immatch/immatch.par create mode 100644 pkg/images/immatch/linmatch.par create mode 100644 pkg/images/immatch/mkpkg create mode 100644 pkg/images/immatch/psfmatch.par create mode 100644 pkg/images/immatch/skymap.cl create mode 100644 pkg/images/immatch/skyxymatch.par create mode 100644 pkg/images/immatch/src/geometry/geofunc.gx create mode 100644 pkg/images/immatch/src/geometry/geofunc.x create mode 100644 pkg/images/immatch/src/geometry/geotimtran.x create mode 100644 pkg/images/immatch/src/geometry/geotran.h create mode 100644 pkg/images/immatch/src/geometry/geotran.x create mode 100644 pkg/images/immatch/src/geometry/geoxytran.gx create mode 100644 pkg/images/immatch/src/geometry/geoxytran.x create mode 100644 pkg/images/immatch/src/geometry/mkpkg create mode 100644 pkg/images/immatch/src/geometry/t_geomap.gx create mode 100644 pkg/images/immatch/src/geometry/t_geomap.x create mode 100644 pkg/images/immatch/src/geometry/t_geotran.x create mode 100644 pkg/images/immatch/src/geometry/t_geoxytran.x create mode 100644 pkg/images/immatch/src/geometry/trinvert.x create mode 100644 pkg/images/immatch/src/imcombine/imcombine.par create mode 100644 pkg/images/immatch/src/imcombine/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/Revisions create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icaclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icaverage.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/iccclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icgdata.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icgrow.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icmedian.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icmm.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icnmodel.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icomb.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icpclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icquad.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsclip.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsigma.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icsort.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/icstat.x create mode 100644 pkg/images/immatch/src/imcombine/src/generic/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/generic/xtimmap.com create mode 100644 pkg/images/immatch/src/imcombine/src/generic/xtimmap.x create mode 100644 pkg/images/immatch/src/imcombine/src/icaclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icaverage.gx create mode 100644 pkg/images/immatch/src/imcombine/src/iccclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icemask.x create mode 100644 pkg/images/immatch/src/imcombine/src/icgdata.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icgrow.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icgscale.x create mode 100644 pkg/images/immatch/src/imcombine/src/ichdr.x create mode 100644 pkg/images/immatch/src/imcombine/src/icimstack.x create mode 100644 pkg/images/immatch/src/imcombine/src/iclog.x create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.com create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.h create mode 100644 pkg/images/immatch/src/imcombine/src/icmask.x create mode 100644 pkg/images/immatch/src/imcombine/src/icmedian.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icmm.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icnmodel.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icomb.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.com create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.h create mode 100644 pkg/images/immatch/src/imcombine/src/icombine.x create mode 100644 pkg/images/immatch/src/imcombine/src/icpclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icpmmap.x create mode 100644 pkg/images/immatch/src/imcombine/src/icquad.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icrmasks.x create mode 100644 pkg/images/immatch/src/imcombine/src/icscale.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsclip.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icsection.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsetout.x create mode 100644 pkg/images/immatch/src/imcombine/src/icsigma.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icsort.gx create mode 100644 pkg/images/immatch/src/imcombine/src/icstat.gx create mode 100644 pkg/images/immatch/src/imcombine/src/mkpkg create mode 100644 pkg/images/immatch/src/imcombine/src/tymax.x create mode 100644 pkg/images/immatch/src/imcombine/src/xtimmap.gx create mode 100644 pkg/images/immatch/src/imcombine/src/xtprocid.x create mode 100644 pkg/images/immatch/src/imcombine/t_imcombine.x create mode 100644 pkg/images/immatch/src/imcombine/x_imcombine.x create mode 100644 pkg/images/immatch/src/linmatch/linmatch.h create mode 100644 pkg/images/immatch/src/linmatch/linmatch.key create mode 100644 pkg/images/immatch/src/linmatch/lsqfit.h create mode 100644 pkg/images/immatch/src/linmatch/mkpkg create mode 100644 pkg/images/immatch/src/linmatch/rglcolon.x create mode 100644 pkg/images/immatch/src/linmatch/rgldbio.x create mode 100644 pkg/images/immatch/src/linmatch/rgldelete.x create mode 100644 pkg/images/immatch/src/linmatch/rgliscale.x create mode 100644 pkg/images/immatch/src/linmatch/rglpars.x create mode 100644 pkg/images/immatch/src/linmatch/rglplot.x create mode 100644 pkg/images/immatch/src/linmatch/rglregions.x create mode 100644 pkg/images/immatch/src/linmatch/rglscale.x create mode 100644 pkg/images/immatch/src/linmatch/rglshow.x create mode 100644 pkg/images/immatch/src/linmatch/rglsqfit.x create mode 100644 pkg/images/immatch/src/linmatch/rgltools.x create mode 100644 pkg/images/immatch/src/linmatch/t_linmatch.x create mode 100644 pkg/images/immatch/src/listmatch/mkpkg create mode 100644 pkg/images/immatch/src/listmatch/t_imctroid.x create mode 100644 pkg/images/immatch/src/listmatch/t_xyxymatch.x create mode 100644 pkg/images/immatch/src/mkpkg create mode 100644 pkg/images/immatch/src/psfmatch/mkpkg create mode 100644 pkg/images/immatch/src/psfmatch/psfmatch.h create mode 100644 pkg/images/immatch/src/psfmatch/psfmatch.key create mode 100644 pkg/images/immatch/src/psfmatch/rgpbckgrd.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpcolon.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpconvolve.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpfft.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpfilter.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpisfm.x create mode 100644 pkg/images/immatch/src/psfmatch/rgppars.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpregions.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpsfm.x create mode 100644 pkg/images/immatch/src/psfmatch/rgpshow.x create mode 100644 pkg/images/immatch/src/psfmatch/rgptools.x create mode 100644 pkg/images/immatch/src/psfmatch/t_psfmatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/mkpkg create mode 100644 pkg/images/immatch/src/wcsmatch/rgmatchio.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_skyxymatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_wcscopy.x create mode 100644 pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x create mode 100644 pkg/images/immatch/src/wcsmatch/wcsxymatch.h create mode 100644 pkg/images/immatch/src/xregister/mkpkg create mode 100644 pkg/images/immatch/src/xregister/oxregister.key create mode 100644 pkg/images/immatch/src/xregister/rgxbckgrd.x create mode 100644 pkg/images/immatch/src/xregister/rgxcolon.x create mode 100644 pkg/images/immatch/src/xregister/rgxcorr.x create mode 100644 pkg/images/immatch/src/xregister/rgxdbio.x create mode 100644 pkg/images/immatch/src/xregister/rgxfft.x create mode 100644 pkg/images/immatch/src/xregister/rgxfit.x create mode 100644 pkg/images/immatch/src/xregister/rgxgpars.x create mode 100644 pkg/images/immatch/src/xregister/rgxicorr.x create mode 100644 pkg/images/immatch/src/xregister/rgximshift.x create mode 100644 pkg/images/immatch/src/xregister/rgxplot.x create mode 100644 pkg/images/immatch/src/xregister/rgxppars.x create mode 100644 pkg/images/immatch/src/xregister/rgxregions.x create mode 100644 pkg/images/immatch/src/xregister/rgxshow.x create mode 100644 pkg/images/immatch/src/xregister/rgxtools.x create mode 100644 pkg/images/immatch/src/xregister/rgxtransform.x create mode 100644 pkg/images/immatch/src/xregister/t_xregister.x create mode 100644 pkg/images/immatch/src/xregister/xregister.h create mode 100644 pkg/images/immatch/src/xregister/xregister.key create mode 100644 pkg/images/immatch/sregister.cl create mode 100644 pkg/images/immatch/wcscopy.par create mode 100644 pkg/images/immatch/wcsmap.cl create mode 100644 pkg/images/immatch/wcsxymatch.par create mode 100644 pkg/images/immatch/wregister.cl create mode 100644 pkg/images/immatch/xregister.par create mode 100644 pkg/images/immatch/xyxymatch.par create mode 100644 pkg/images/imutil/Revisions create mode 100644 pkg/images/imutil/_imaxes.par create mode 100644 pkg/images/imutil/chpixtype.par create mode 100644 pkg/images/imutil/doc/chpix.hlp create mode 100644 pkg/images/imutil/doc/hedit.hlp create mode 100644 pkg/images/imutil/doc/hselect.hlp create mode 100644 pkg/images/imutil/doc/imarith.hlp create mode 100644 pkg/images/imutil/doc/imcopy.hlp create mode 100644 pkg/images/imutil/doc/imdelete.hlp create mode 100644 pkg/images/imutil/doc/imdivide.hlp create mode 100644 pkg/images/imutil/doc/imexpr.hlp create mode 100644 pkg/images/imutil/doc/imfunction.hlp create mode 100644 pkg/images/imutil/doc/imgets.hlp create mode 100644 pkg/images/imutil/doc/imheader.hlp create mode 100644 pkg/images/imutil/doc/imhistogram.hlp create mode 100644 pkg/images/imutil/doc/imjoin.hlp create mode 100644 pkg/images/imutil/doc/imrename.hlp create mode 100644 pkg/images/imutil/doc/imreplace.hlp create mode 100644 pkg/images/imutil/doc/imslice.hlp create mode 100644 pkg/images/imutil/doc/imstack.hlp create mode 100644 pkg/images/imutil/doc/imstat.hlp create mode 100644 pkg/images/imutil/doc/imsum.hlp create mode 100644 pkg/images/imutil/doc/imtile.hlp create mode 100644 pkg/images/imutil/doc/listpixels.hlp create mode 100644 pkg/images/imutil/doc/minmax.hlp create mode 100644 pkg/images/imutil/doc/nhedit.hlp create mode 100644 pkg/images/imutil/doc/sections.hlp create mode 100644 pkg/images/imutil/hedit.par create mode 100644 pkg/images/imutil/hselect.par create mode 100644 pkg/images/imutil/imarith.par create mode 100644 pkg/images/imutil/imcopy.par create mode 100644 pkg/images/imutil/imdelete.par create mode 100644 pkg/images/imutil/imdivide.par create mode 100644 pkg/images/imutil/imexpr.par create mode 100644 pkg/images/imutil/imfunction.par create mode 100644 pkg/images/imutil/imgets.par create mode 100644 pkg/images/imutil/imheader.par create mode 100644 pkg/images/imutil/imhistogram.par create mode 100644 pkg/images/imutil/imjoin.par create mode 100644 pkg/images/imutil/imrename.par create mode 100644 pkg/images/imutil/imreplace.par create mode 100644 pkg/images/imutil/imslice.par create mode 100644 pkg/images/imutil/imstack.par create mode 100644 pkg/images/imutil/imstatistics.par create mode 100644 pkg/images/imutil/imsum.par create mode 100644 pkg/images/imutil/imtile.par create mode 100644 pkg/images/imutil/imutil.cl create mode 100644 pkg/images/imutil/imutil.hd create mode 100644 pkg/images/imutil/imutil.men create mode 100644 pkg/images/imutil/imutil.par create mode 100644 pkg/images/imutil/listpixels.par create mode 100644 pkg/images/imutil/minmax.par create mode 100644 pkg/images/imutil/mkpkg create mode 100644 pkg/images/imutil/nhedit.par create mode 100644 pkg/images/imutil/sections.par create mode 100644 pkg/images/imutil/src/generic/imaadd.x create mode 100644 pkg/images/imutil/src/generic/imadiv.x create mode 100644 pkg/images/imutil/src/generic/imamax.x create mode 100644 pkg/images/imutil/src/generic/imamin.x create mode 100644 pkg/images/imutil/src/generic/imamul.x create mode 100644 pkg/images/imutil/src/generic/imanl.x create mode 100644 pkg/images/imutil/src/generic/imasub.x create mode 100644 pkg/images/imutil/src/generic/imfuncs.x create mode 100644 pkg/images/imutil/src/generic/imjoin.x create mode 100644 pkg/images/imutil/src/generic/imrep.x create mode 100644 pkg/images/imutil/src/generic/imsum.x create mode 100644 pkg/images/imutil/src/generic/mkpkg create mode 100644 pkg/images/imutil/src/getcmd.x create mode 100644 pkg/images/imutil/src/gettok.h create mode 100644 pkg/images/imutil/src/gettok.x create mode 100644 pkg/images/imutil/src/hedit.x create mode 100644 pkg/images/imutil/src/hselect.x create mode 100644 pkg/images/imutil/src/iegsym.x create mode 100644 pkg/images/imutil/src/imaadd.gx create mode 100644 pkg/images/imutil/src/imadiv.gx create mode 100644 pkg/images/imutil/src/imamax.gx create mode 100644 pkg/images/imutil/src/imamin.gx create mode 100644 pkg/images/imutil/src/imamul.gx create mode 100644 pkg/images/imutil/src/imanl.gx create mode 100644 pkg/images/imutil/src/imasub.gx create mode 100644 pkg/images/imutil/src/imdelete.x create mode 100644 pkg/images/imutil/src/imexpr.gx create mode 100644 pkg/images/imutil/src/imexpr.x create mode 100644 pkg/images/imutil/src/imfuncs.gx create mode 100644 pkg/images/imutil/src/imfunction.x create mode 100644 pkg/images/imutil/src/imgets.x create mode 100644 pkg/images/imutil/src/imheader.x create mode 100644 pkg/images/imutil/src/imhistogram.x create mode 100644 pkg/images/imutil/src/imjoin.gx create mode 100644 pkg/images/imutil/src/imminmax.x create mode 100644 pkg/images/imutil/src/imrep.gx create mode 100644 pkg/images/imutil/src/imstat.h create mode 100644 pkg/images/imutil/src/imsum.gx create mode 100644 pkg/images/imutil/src/imsum.h create mode 100644 pkg/images/imutil/src/imtile.h create mode 100644 pkg/images/imutil/src/listpixels.x create mode 100644 pkg/images/imutil/src/minmax.x create mode 100644 pkg/images/imutil/src/mkpkg create mode 100644 pkg/images/imutil/src/nhedit.x create mode 100644 pkg/images/imutil/src/t_chpix.x create mode 100644 pkg/images/imutil/src/t_imarith.x create mode 100644 pkg/images/imutil/src/t_imaxes.x create mode 100644 pkg/images/imutil/src/t_imcopy.x create mode 100644 pkg/images/imutil/src/t_imdivide.x create mode 100644 pkg/images/imutil/src/t_imjoin.x create mode 100644 pkg/images/imutil/src/t_imrename.x create mode 100644 pkg/images/imutil/src/t_imreplace.x create mode 100644 pkg/images/imutil/src/t_imslice.x create mode 100644 pkg/images/imutil/src/t_imstack.x create mode 100644 pkg/images/imutil/src/t_imstat.x create mode 100644 pkg/images/imutil/src/t_imsum.x create mode 100644 pkg/images/imutil/src/t_imtile.x create mode 100644 pkg/images/imutil/src/t_minmax.x create mode 100644 pkg/images/imutil/src/t_sections.x create mode 100644 pkg/images/lib/coomap.key create mode 100644 pkg/images/lib/geofit.gx create mode 100644 pkg/images/lib/geofit.x create mode 100644 pkg/images/lib/geofiti.x create mode 100644 pkg/images/lib/geogmap.gx create mode 100644 pkg/images/lib/geogmap.h create mode 100644 pkg/images/lib/geogmap.x create mode 100644 pkg/images/lib/geogmapi.x create mode 100644 pkg/images/lib/geograph.gx create mode 100644 pkg/images/lib/geograph.x create mode 100644 pkg/images/lib/geomap.h create mode 100644 pkg/images/lib/geomap.key create mode 100644 pkg/images/lib/geoset.x create mode 100644 pkg/images/lib/imcopy.x create mode 100644 pkg/images/lib/liststr.gx create mode 100644 pkg/images/lib/liststr.x create mode 100644 pkg/images/lib/mkpkg create mode 100644 pkg/images/lib/rgbckgrd.x create mode 100644 pkg/images/lib/rgccwcs.x create mode 100644 pkg/images/lib/rgcontour.x create mode 100644 pkg/images/lib/rgfft.x create mode 100644 pkg/images/lib/rglltran.x create mode 100644 pkg/images/lib/rgmerge.x create mode 100644 pkg/images/lib/rgsort.x create mode 100644 pkg/images/lib/rgtransform.x create mode 100644 pkg/images/lib/rgwrdstr.x create mode 100644 pkg/images/lib/rgxymatch.x create mode 100644 pkg/images/lib/xymatch.x create mode 100644 pkg/images/lib/xyxymatch.h create mode 100644 pkg/images/lib/zzdebug.x create mode 100644 pkg/images/mkpkg create mode 100644 pkg/images/notes create mode 100644 pkg/images/tv/Revisions create mode 100644 pkg/images/tv/_dcontrol.par create mode 100644 pkg/images/tv/cimexam.par create mode 100644 pkg/images/tv/display.par create mode 100644 pkg/images/tv/display/README create mode 100755 pkg/images/tv/display/ace.h create mode 100644 pkg/images/tv/display/display.h create mode 100644 pkg/images/tv/display/dsmap.x create mode 100644 pkg/images/tv/display/dspmmap.x create mode 100644 pkg/images/tv/display/dsulut.x create mode 100644 pkg/images/tv/display/findz.x create mode 100644 pkg/images/tv/display/gwindow.h create mode 100644 pkg/images/tv/display/iis.com create mode 100644 pkg/images/tv/display/iis.h create mode 100644 pkg/images/tv/display/iisblk.x create mode 100644 pkg/images/tv/display/iiscls.x create mode 100644 pkg/images/tv/display/iisers.x create mode 100644 pkg/images/tv/display/iisflu.x create mode 100644 pkg/images/tv/display/iisgop.x create mode 100644 pkg/images/tv/display/iishdr.x create mode 100644 pkg/images/tv/display/iisio.x create mode 100644 pkg/images/tv/display/iismtc.x create mode 100644 pkg/images/tv/display/iisofm.x create mode 100644 pkg/images/tv/display/iisopn.x create mode 100644 pkg/images/tv/display/iispio.x create mode 100644 pkg/images/tv/display/iisrcr.x create mode 100644 pkg/images/tv/display/iisrd.x create mode 100644 pkg/images/tv/display/iisrgb.x create mode 100644 pkg/images/tv/display/iissfr.x create mode 100644 pkg/images/tv/display/iisstt.x create mode 100644 pkg/images/tv/display/iiswcr.x create mode 100644 pkg/images/tv/display/iiswnd.x create mode 100644 pkg/images/tv/display/iiswr.x create mode 100644 pkg/images/tv/display/iiswt.x create mode 100644 pkg/images/tv/display/iiszm.x create mode 100644 pkg/images/tv/display/imd.com create mode 100644 pkg/images/tv/display/imdgcur.x create mode 100644 pkg/images/tv/display/imdgetwcs.x create mode 100644 pkg/images/tv/display/imdmapfr.x create mode 100644 pkg/images/tv/display/imdmapping.x create mode 100644 pkg/images/tv/display/imdopen.x create mode 100644 pkg/images/tv/display/imdputwcs.x create mode 100644 pkg/images/tv/display/imdrcur.x create mode 100644 pkg/images/tv/display/imdrcuro.x create mode 100644 pkg/images/tv/display/imdsetwcs.x create mode 100644 pkg/images/tv/display/imdwcs.x create mode 100644 pkg/images/tv/display/imdwcsver.x create mode 100644 pkg/images/tv/display/maskcolor.x create mode 100644 pkg/images/tv/display/maxmin.x create mode 100644 pkg/images/tv/display/mkpkg create mode 100644 pkg/images/tv/display/sigl2.x create mode 100644 pkg/images/tv/display/sigm2.x create mode 100644 pkg/images/tv/display/t_dcontrol.x create mode 100644 pkg/images/tv/display/t_display.x create mode 100644 pkg/images/tv/display/zardim.x create mode 100644 pkg/images/tv/display/zawrim.x create mode 100644 pkg/images/tv/display/zawtim.x create mode 100644 pkg/images/tv/display/zblkim.x create mode 100644 pkg/images/tv/display/zclrim.x create mode 100644 pkg/images/tv/display/zclsim.x create mode 100644 pkg/images/tv/display/zdisplay.h create mode 100644 pkg/images/tv/display/zersim.x create mode 100644 pkg/images/tv/display/zfrmim.x create mode 100644 pkg/images/tv/display/zmapim.x create mode 100644 pkg/images/tv/display/zmtcim.x create mode 100644 pkg/images/tv/display/zopnim.x create mode 100644 pkg/images/tv/display/zrcrim.x create mode 100644 pkg/images/tv/display/zrgbim.x create mode 100644 pkg/images/tv/display/zrmim.x create mode 100644 pkg/images/tv/display/zscale.x create mode 100644 pkg/images/tv/display/zsttim.x create mode 100644 pkg/images/tv/display/zwndim.x create mode 100644 pkg/images/tv/display/zzdebug.x create mode 100644 pkg/images/tv/doc/Tv.hlp create mode 100644 pkg/images/tv/doc/bpmedit.hlp create mode 100644 pkg/images/tv/doc/display.hlp create mode 100644 pkg/images/tv/doc/imedit.hlp create mode 100644 pkg/images/tv/doc/imexamine.hlp create mode 100644 pkg/images/tv/doc/tvmark.hlp create mode 100644 pkg/images/tv/doc/wcslab.hlp create mode 100644 pkg/images/tv/eimexam.par create mode 100644 pkg/images/tv/himexam.par create mode 100644 pkg/images/tv/iis/README create mode 100644 pkg/images/tv/iis/blink.cl create mode 100644 pkg/images/tv/iis/blink.par create mode 100644 pkg/images/tv/iis/cv.par create mode 100644 pkg/images/tv/iis/cvl.par create mode 100644 pkg/images/tv/iis/doc/Cv.spc.hlp create mode 100644 pkg/images/tv/iis/doc/blink.hlp create mode 100644 pkg/images/tv/iis/doc/cv.doc create mode 100644 pkg/images/tv/iis/doc/cv.hlp create mode 100644 pkg/images/tv/iis/doc/cv.ms create mode 100644 pkg/images/tv/iis/doc/cvl.hlp create mode 100644 pkg/images/tv/iis/doc/erase.hlp create mode 100644 pkg/images/tv/iis/doc/frame.hlp create mode 100644 pkg/images/tv/iis/doc/lumatch.hlp create mode 100644 pkg/images/tv/iis/doc/monochrome.hlp create mode 100644 pkg/images/tv/iis/doc/pseudocolor.hlp create mode 100644 pkg/images/tv/iis/doc/rgb.hlp create mode 100644 pkg/images/tv/iis/doc/window.hlp create mode 100644 pkg/images/tv/iis/doc/zoom.hlp create mode 100644 pkg/images/tv/iis/erase.cl create mode 100644 pkg/images/tv/iis/erase.par create mode 100644 pkg/images/tv/iis/frame.cl create mode 100644 pkg/images/tv/iis/giis.par create mode 100644 pkg/images/tv/iis/ids/doc/Imdis.hlp create mode 100644 pkg/images/tv/iis/ids/doc/Note.misc create mode 100644 pkg/images/tv/iis/ids/doc/Note.pixel create mode 100644 pkg/images/tv/iis/ids/doc/file.doc create mode 100644 pkg/images/tv/iis/ids/doc/iis.doc create mode 100644 pkg/images/tv/iis/ids/font.com create mode 100644 pkg/images/tv/iis/ids/font.h create mode 100644 pkg/images/tv/iis/ids/idscancel.x create mode 100644 pkg/images/tv/iis/ids/idschars.x create mode 100644 pkg/images/tv/iis/ids/idsclear.x create mode 100644 pkg/images/tv/iis/ids/idsclose.x create mode 100644 pkg/images/tv/iis/ids/idsclosews.x create mode 100644 pkg/images/tv/iis/ids/idscround.x create mode 100644 pkg/images/tv/iis/ids/idsdrawch.x create mode 100644 pkg/images/tv/iis/ids/idsescape.x create mode 100644 pkg/images/tv/iis/ids/idsfa.x create mode 100644 pkg/images/tv/iis/ids/idsfaset.x create mode 100644 pkg/images/tv/iis/ids/idsflush.x create mode 100644 pkg/images/tv/iis/ids/idsfont.x create mode 100644 pkg/images/tv/iis/ids/idsgcell.x create mode 100644 pkg/images/tv/iis/ids/idsgcur.x create mode 100644 pkg/images/tv/iis/ids/idsinit.x create mode 100644 pkg/images/tv/iis/ids/idsline.x create mode 100644 pkg/images/tv/iis/ids/idslutfill.x create mode 100644 pkg/images/tv/iis/ids/idsopen.x create mode 100644 pkg/images/tv/iis/ids/idsopenws.x create mode 100644 pkg/images/tv/iis/ids/idspcell.x create mode 100644 pkg/images/tv/iis/ids/idspl.x create mode 100644 pkg/images/tv/iis/ids/idsplset.x create mode 100644 pkg/images/tv/iis/ids/idspm.x create mode 100644 pkg/images/tv/iis/ids/idspmset.x create mode 100644 pkg/images/tv/iis/ids/idspoint.x create mode 100644 pkg/images/tv/iis/ids/idsreset.x create mode 100644 pkg/images/tv/iis/ids/idsrestore.x create mode 100644 pkg/images/tv/iis/ids/idssave.x create mode 100644 pkg/images/tv/iis/ids/idsscur.x create mode 100644 pkg/images/tv/iis/ids/idsstream.x create mode 100644 pkg/images/tv/iis/ids/idstx.x create mode 100644 pkg/images/tv/iis/ids/idstxset.x create mode 100644 pkg/images/tv/iis/ids/idsvector.x create mode 100644 pkg/images/tv/iis/ids/mkpkg create mode 100644 pkg/images/tv/iis/ids/testcode/README create mode 100644 pkg/images/tv/iis/ids/testcode/box.x create mode 100644 pkg/images/tv/iis/ids/testcode/boxin.x create mode 100644 pkg/images/tv/iis/ids/testcode/crin.x create mode 100644 pkg/images/tv/iis/ids/testcode/grey.x create mode 100644 pkg/images/tv/iis/ids/testcode/grin.x create mode 100644 pkg/images/tv/iis/ids/testcode/scr.x create mode 100644 pkg/images/tv/iis/ids/testcode/scrin.x create mode 100644 pkg/images/tv/iis/ids/testcode/sn.x create mode 100644 pkg/images/tv/iis/ids/testcode/t_giis.x create mode 100644 pkg/images/tv/iis/ids/testcode/zm.x create mode 100644 pkg/images/tv/iis/ids/testcode/zmin.x create mode 100644 pkg/images/tv/iis/ids/testcode/zztest.x create mode 100644 pkg/images/tv/iis/iis.cl create mode 100644 pkg/images/tv/iis/iis.hd create mode 100644 pkg/images/tv/iis/iis.men create mode 100644 pkg/images/tv/iis/iis.par create mode 100644 pkg/images/tv/iis/iism70/README create mode 100644 pkg/images/tv/iis/iism70/idsexpand.x create mode 100644 pkg/images/tv/iis/iism70/iis.com create mode 100644 pkg/images/tv/iis/iism70/iis.h create mode 100644 pkg/images/tv/iis/iism70/iisbutton.x create mode 100644 pkg/images/tv/iis/iism70/iiscls.x create mode 100644 pkg/images/tv/iis/iism70/iiscursor.x create mode 100644 pkg/images/tv/iis/iism70/iishdr.x create mode 100644 pkg/images/tv/iis/iism70/iishisto.x create mode 100644 pkg/images/tv/iis/iism70/iisifm.x create mode 100644 pkg/images/tv/iis/iism70/iisio.x create mode 100644 pkg/images/tv/iis/iism70/iislut.x create mode 100644 pkg/images/tv/iis/iism70/iismatch.x create mode 100644 pkg/images/tv/iis/iism70/iisminmax.x create mode 100644 pkg/images/tv/iis/iism70/iisoffset.x create mode 100644 pkg/images/tv/iis/iism70/iisofm.x create mode 100644 pkg/images/tv/iis/iism70/iisopn.x create mode 100644 pkg/images/tv/iis/iism70/iispack.x create mode 100644 pkg/images/tv/iis/iism70/iispio.x create mode 100644 pkg/images/tv/iis/iism70/iisrange.x create mode 100644 pkg/images/tv/iis/iism70/iisrd.x create mode 100644 pkg/images/tv/iis/iism70/iisscroll.x create mode 100644 pkg/images/tv/iis/iism70/iissplit.x create mode 100644 pkg/images/tv/iis/iism70/iistball.x create mode 100644 pkg/images/tv/iis/iism70/iiswr.x create mode 100644 pkg/images/tv/iis/iism70/iiswt.x create mode 100644 pkg/images/tv/iis/iism70/iiszoom.x create mode 100644 pkg/images/tv/iis/iism70/mkpkg create mode 100644 pkg/images/tv/iis/iism70/zardim.x create mode 100644 pkg/images/tv/iis/iism70/zawrim.x create mode 100644 pkg/images/tv/iis/iism70/zawtim.x create mode 100644 pkg/images/tv/iis/iism70/zclear.x create mode 100644 pkg/images/tv/iis/iism70/zclsim.x create mode 100644 pkg/images/tv/iis/iism70/zcontrol.x create mode 100644 pkg/images/tv/iis/iism70/zcursor_read.x create mode 100644 pkg/images/tv/iis/iism70/zcursor_set.x create mode 100644 pkg/images/tv/iis/iism70/zdisplay_g.x create mode 100644 pkg/images/tv/iis/iism70/zdisplay_i.x create mode 100644 pkg/images/tv/iis/iism70/zinit.x create mode 100644 pkg/images/tv/iis/iism70/zopnim.x create mode 100644 pkg/images/tv/iis/iism70/zreset.x create mode 100644 pkg/images/tv/iis/iism70/zrestore.x create mode 100644 pkg/images/tv/iis/iism70/zsave.x create mode 100644 pkg/images/tv/iis/iism70/zseek.x create mode 100644 pkg/images/tv/iis/iism70/zsetup.x create mode 100644 pkg/images/tv/iis/iism70/zsnap.com create mode 100644 pkg/images/tv/iis/iism70/zsnap.x create mode 100644 pkg/images/tv/iis/iism70/zsnapinit.x create mode 100644 pkg/images/tv/iis/iism70/zsttim.x create mode 100644 pkg/images/tv/iis/lib/ids.com create mode 100644 pkg/images/tv/iis/lib/ids.h create mode 100644 pkg/images/tv/iis/lumatch.cl create mode 100644 pkg/images/tv/iis/lumatch.par create mode 100644 pkg/images/tv/iis/mkpkg create mode 100644 pkg/images/tv/iis/monochrome.cl create mode 100644 pkg/images/tv/iis/pseudocolor.cl create mode 100644 pkg/images/tv/iis/pseudocolor.par create mode 100644 pkg/images/tv/iis/rgb.cl create mode 100644 pkg/images/tv/iis/rgb.par create mode 100644 pkg/images/tv/iis/src/blink.x create mode 100644 pkg/images/tv/iis/src/clear.x create mode 100644 pkg/images/tv/iis/src/cv.com create mode 100644 pkg/images/tv/iis/src/cv.h create mode 100644 pkg/images/tv/iis/src/cv.x create mode 100644 pkg/images/tv/iis/src/cvparse.x create mode 100644 pkg/images/tv/iis/src/cvulut.x create mode 100644 pkg/images/tv/iis/src/cvutil.x create mode 100644 pkg/images/tv/iis/src/display.x create mode 100644 pkg/images/tv/iis/src/gwindow.h create mode 100644 pkg/images/tv/iis/src/load1.x create mode 100644 pkg/images/tv/iis/src/load2.x create mode 100644 pkg/images/tv/iis/src/map.x create mode 100644 pkg/images/tv/iis/src/match.x create mode 100644 pkg/images/tv/iis/src/maxmin.x create mode 100644 pkg/images/tv/iis/src/mkpkg create mode 100644 pkg/images/tv/iis/src/offset.x create mode 100644 pkg/images/tv/iis/src/pan.x create mode 100644 pkg/images/tv/iis/src/range.x create mode 100644 pkg/images/tv/iis/src/rdcur.x create mode 100644 pkg/images/tv/iis/src/reset.x create mode 100644 pkg/images/tv/iis/src/sigl2.x create mode 100644 pkg/images/tv/iis/src/snap.x create mode 100644 pkg/images/tv/iis/src/split.x create mode 100644 pkg/images/tv/iis/src/tell.x create mode 100644 pkg/images/tv/iis/src/text.x create mode 100644 pkg/images/tv/iis/src/window.x create mode 100644 pkg/images/tv/iis/src/zoom.x create mode 100644 pkg/images/tv/iis/src/zscale.x create mode 100644 pkg/images/tv/iis/window.cl create mode 100644 pkg/images/tv/iis/x_iis.x create mode 100644 pkg/images/tv/iis/zoom.cl create mode 100644 pkg/images/tv/iis/zoom.par create mode 100644 pkg/images/tv/imedit.par create mode 100644 pkg/images/tv/imedit/bpmedit.cl create mode 100644 pkg/images/tv/imedit/bpmedit.key create mode 100644 pkg/images/tv/imedit/epbackground.x create mode 100644 pkg/images/tv/imedit/epcol.x create mode 100644 pkg/images/tv/imedit/epcolon.x create mode 100644 pkg/images/tv/imedit/epconstant.x create mode 100644 pkg/images/tv/imedit/epdisplay.x create mode 100644 pkg/images/tv/imedit/epdosurface.x create mode 100644 pkg/images/tv/imedit/epgcur.x create mode 100644 pkg/images/tv/imedit/epgdata.x create mode 100644 pkg/images/tv/imedit/epgsfit.x create mode 100644 pkg/images/tv/imedit/epimcopy.x create mode 100644 pkg/images/tv/imedit/epinput.x create mode 100644 pkg/images/tv/imedit/epix.h create mode 100644 pkg/images/tv/imedit/epline.x create mode 100644 pkg/images/tv/imedit/epmask.x create mode 100644 pkg/images/tv/imedit/epmove.x create mode 100644 pkg/images/tv/imedit/epnoise.x create mode 100644 pkg/images/tv/imedit/epreplace.gx create mode 100644 pkg/images/tv/imedit/epreplace.x create mode 100644 pkg/images/tv/imedit/epsearch.x create mode 100644 pkg/images/tv/imedit/epsetpars.x create mode 100644 pkg/images/tv/imedit/epstatistics.x create mode 100644 pkg/images/tv/imedit/epsurface.x create mode 100644 pkg/images/tv/imedit/imedit.key create mode 100644 pkg/images/tv/imedit/mkpkg create mode 100644 pkg/images/tv/imedit/t_imedit.x create mode 100644 pkg/images/tv/imexamine.par create mode 100644 pkg/images/tv/imexamine/iecimexam.x create mode 100644 pkg/images/tv/imexamine/iecolon.x create mode 100644 pkg/images/tv/imexamine/iedisplay.x create mode 100644 pkg/images/tv/imexamine/ieeimexam.x create mode 100644 pkg/images/tv/imexamine/iegcur.x create mode 100644 pkg/images/tv/imexamine/iegdata.x create mode 100644 pkg/images/tv/imexamine/iegimage.x create mode 100644 pkg/images/tv/imexamine/iegnfr.x create mode 100644 pkg/images/tv/imexamine/iegraph.x create mode 100644 pkg/images/tv/imexamine/iehimexam.x create mode 100644 pkg/images/tv/imexamine/ieimname.x create mode 100644 pkg/images/tv/imexamine/iejimexam.x create mode 100644 pkg/images/tv/imexamine/ielimexam.x create mode 100644 pkg/images/tv/imexamine/iemw.x create mode 100644 pkg/images/tv/imexamine/ieopenlog.x create mode 100644 pkg/images/tv/imexamine/iepos.x create mode 100644 pkg/images/tv/imexamine/ieprint.x create mode 100644 pkg/images/tv/imexamine/ieqrimexam.x create mode 100644 pkg/images/tv/imexamine/ierimexam.x create mode 100644 pkg/images/tv/imexamine/iesimexam.x create mode 100644 pkg/images/tv/imexamine/iestatistics.x create mode 100644 pkg/images/tv/imexamine/ietimexam.x create mode 100644 pkg/images/tv/imexamine/ievimexam.x create mode 100644 pkg/images/tv/imexamine/imexam.h create mode 100644 pkg/images/tv/imexamine/imexamine.par create mode 100644 pkg/images/tv/imexamine/mkpkg create mode 100644 pkg/images/tv/imexamine/starfocus.h create mode 100644 pkg/images/tv/imexamine/stfmeasure.x create mode 100644 pkg/images/tv/imexamine/stfprofile.x create mode 100644 pkg/images/tv/imexamine/t_imexam.x create mode 100644 pkg/images/tv/imexamine/x_imexam.x create mode 100644 pkg/images/tv/jimexam.par create mode 100644 pkg/images/tv/kimexam.par create mode 100644 pkg/images/tv/limexam.par create mode 100644 pkg/images/tv/mkpkg create mode 100644 pkg/images/tv/rimexam.par create mode 100644 pkg/images/tv/simexam.par create mode 100644 pkg/images/tv/tv.cl create mode 100644 pkg/images/tv/tv.hd create mode 100644 pkg/images/tv/tv.men create mode 100644 pkg/images/tv/tv.par create mode 100644 pkg/images/tv/tvmark.par create mode 100644 pkg/images/tv/tvmark/asciilook.inc create mode 100644 pkg/images/tv/tvmark/mkbmark.x create mode 100644 pkg/images/tv/tvmark/mkcolon.x create mode 100644 pkg/images/tv/tvmark/mkfind.x create mode 100644 pkg/images/tv/tvmark/mkgmarks.x create mode 100644 pkg/images/tv/tvmark/mkgpars.x create mode 100644 pkg/images/tv/tvmark/mkgscur.x create mode 100644 pkg/images/tv/tvmark/mkmag.x create mode 100644 pkg/images/tv/tvmark/mkmark.x create mode 100644 pkg/images/tv/tvmark/mknew.x create mode 100644 pkg/images/tv/tvmark/mkonemark.x create mode 100644 pkg/images/tv/tvmark/mkoutname.x create mode 100644 pkg/images/tv/tvmark/mkpkg create mode 100644 pkg/images/tv/tvmark/mkppars.x create mode 100644 pkg/images/tv/tvmark/mkremove.x create mode 100644 pkg/images/tv/tvmark/mkshow.x create mode 100644 pkg/images/tv/tvmark/mktext.x create mode 100644 pkg/images/tv/tvmark/mktools.x create mode 100644 pkg/images/tv/tvmark/pixelfont.inc create mode 100644 pkg/images/tv/tvmark/t_tvmark.x create mode 100644 pkg/images/tv/tvmark/tvmark.h create mode 100644 pkg/images/tv/vimexam.par create mode 100644 pkg/images/tv/wcslab.par create mode 100644 pkg/images/tv/wcslab/mkpkg create mode 100644 pkg/images/tv/wcslab/t_wcslab.x create mode 100644 pkg/images/tv/wcslab/wcs_desc.h create mode 100644 pkg/images/tv/wcslab/wcslab.h create mode 100644 pkg/images/tv/wcslab/wcslab.x create mode 100644 pkg/images/tv/wcslab/wlgrid.x create mode 100644 pkg/images/tv/wcslab/wllabel.x create mode 100644 pkg/images/tv/wcslab/wlsetup.x create mode 100644 pkg/images/tv/wcslab/wlutil.x create mode 100644 pkg/images/tv/wcslab/wlwcslab.x create mode 100644 pkg/images/tv/wcslab/zz.x create mode 100644 pkg/images/tv/wcspars.par create mode 100644 pkg/images/tv/wlpars.par create mode 100644 pkg/images/tv/x_tv.x create mode 100644 pkg/images/x_images.x (limited to 'pkg/images') diff --git a/pkg/images/README b/pkg/images/README new file mode 100644 index 00000000..cc538f1a --- /dev/null +++ b/pkg/images/README @@ -0,0 +1,10 @@ +IMAGES -- General image processing tasks and utilties. +---------------------------------------------------------- + +imcoords - Image world coordinate handling +imfilter - Filtering (tasks which modify pixel values) +imfit - Fitting (fitting functions to image data) +imgeom - Geometry (tasks which move pixels around) +immatch - Image matching +imutil - Miscellaneous image utilties +tv - Image display (prototype package) diff --git a/pkg/images/Revisions b/pkg/images/Revisions new file mode 100644 index 00000000..f0f2e070 --- /dev/null +++ b/pkg/images/Revisions @@ -0,0 +1,3680 @@ +.help revisions Jan97 images +.nf + +imfit/src/imsurfit.x + The 'fbuf' and 'colsfit' pointers were declared with the wrong type. + (5/4/13, MJF) + +tv/imedit/epstatistics.x + The 'x', 'y', and 'z' pointers were declared as TY_INT instead of TY_REAL + (5/4/13, MJF) + +immatch/src/linmatch/rgltools.x + There were TY_INT arrays being called with Memr[] (4/20/13) + +imcoords/src/t_ccmap.x + There were missing arguments that will cause "refpoint=user" to crash + with a floating point overflow. (9/21/12, Valdes) + +imatch/src/imcombine/src/icombine.x + Removed TRAP debug message. (5/11/12, Valdes) + +imatch/src/imcombine/src/icsetout.x + Changed 1 Gpixel limit (see 6/11/09) to 100 Gpixel. (5/11/12, Valdes) + +immatch/src/geometry/t_geomap.gx +lib/geofit.gx + The real path of t_geomap.gx code treated geomap.h floating parameters + as being of type PIXEL rather than double. Also in the real path + of geofit.gx there was an attempt to coerce an INDEFD to a real value. + (5/10/12, Valdes) + +imcoords/src/t_ccmap.x +imcoords/ccmap.par +lib/geofit.x +lib/geogmap.gx + Updates to the previous changes. A new option "tweak" was added to + the values for the "refpoint" parameter to allow controlling whether + to tweak the input tangent point. (3/16/12, Valdes) + +imcoords/src/t_ccmap.x +imcoords/ccmap.par +imcoords/doc/ccmap.hlp + Changes to allow constraining WCS solutions to specified tangent point + parameters (reference pixel and reference coordinate). + + 1. New parameters xref and yref can be set to a value or header keyword + in order to constrain the solution to the specified reference pixel. + + This adds parameters so potentially requires users to update scripts. + + (2/7/12, Valdes) + +lib/geoset.x + +lib/mkpkg +lib/geofit.x +lib/geomap.h +lib/geofit.gx + These changes are to allow calling gsurfit with the fit constrained + to a specific reference point and value. This is used by ccmap to + constrain WCS solutions to specified CRVAL/CRPIX values. + + 1. Added geoset procedures to set some new parameters. + 2. The new parameters are passed on to gsurfit. + + These changes should be transparent to any existing usage. These + chanages are coupled to changes in gsurfit. + + (2/7/12, Valdes) + + +===== +v2.16 +===== + +immatch/imcombine.par + The enumerated values for the combine value had to be expanded to + agree with the help page and the task functionality. (Valdes, 12-16-11) + +imgeom/doc/imlintran.hlp + Corrected the description of the image scaling to remove extra + terms (i.e. "xt = xt/xmag + yt/ymag" becomes "xt = xt/xmag") (12/16/11) + +imcoords/src/t_ccmap.x +imcoords/doc/ccmap.hlp + Modifications to allow using multiple exposures to produce one + solution. This was done in such a way that no new parameters are + needed. (8/9/11, Valdes) + +immatch/src/imcombine/src/icgdata.gx + The image id data was not properly initialized when some data was + excluded causing a segmentation fault with the grow option is used + with masks or non-overlapping data. (4/1/11, Valdes) + +immatch/src/imcombine/mkpkg + The "standalone" target was not correct for the imc library changes. + (4/1/11, Valdes) + +immatch/src/imcombine/src/icomb.gx + A feature to reduced memory requirments by removing the user area of + the image header structure is a problem when masks and wcs offsets are + used due to the need for the mask matching code to access the wcs. For + now this feature is turned off. (3/4/11, Valdes) + +======== +V2.15.1a +======== + +immatch/src/imcombine/src/icaclip.gx +immatch/src/imcombine/src/iccclip.gx +immatch/src/imcombine/src/icmm.gx +immatch/src/imcombine/src/icpclip.gx +immatch/src/imcombine/src/icsclip.gx + The change that allowed the array containing the number of good pixels + to be negative was not taken into account in these routines. While I + did not fully check the logic the simple step of applying a floor of + zero to the array values should be safe since these routines were + originally written to expect values from 0 on up. (1/10/11, Valdes) + +immatch/src/imcombine/src/generic/mkpkg +immatch/src/imcombine/src/mkpkg +immatch/src/imcombine/mkpkg +mkpkg + Converted the generic combining code into a core library so that + other versions of combine (such as in ccdred, mscred, nfextern) + will share the same code rather than have copies. (1/4/11, Valdes) + +immatch/src/imcombine/src/ichdr.x + Accidentally left a debugging statement that printed the letter C. + This is now removed. (12/10/10, Valdes) + +immatch/src/imcombine/src/ichdr.x + The step that stripped any directory from the image name for the $I + value of the imcmb parameter failed for extensions. (11/17/10, Valdes) + +immatch/doc/imcombine.hlp +immatch/src/imcombine/imcombine.par +immatch/src/imcombine/src/generic/mkpkg +immatch/src/imcombine/src/icaverage.gx +immatch/src/imcombine/src/iclog.x +immatch/src/imcombine/src/icnmodel.gx + +immatch/src/imcombine/src/icomb.gx +immatch/src/imcombine/src/icombine.h +immatch/src/imcombine/src/icquad.gx + +immatch/src/imcombine/src/mkpkg + Added two combine options -- "quadrature" and "nmodel". This allows + sigma images to be input and output. (4/21/10, Valdes) + +immatch/src/imcombine/t_imcombine.x +immatch/imcombine.par +immatch/src/imcombine/imcombine.par +immatch/src/imcombine/src/generic/icmedian.x +immatch/src/imcombine/src/icmedian.gx +immatch/src/imcombine/src/icombine.com +immatch/src/imcombine/src/icombine.h +immatch/doc/imcombine.hlp + Added a specialized "lmedian" option to use the lower value when there + are only two values contributing to the output. (4/12/10, Valdes) + +images/imcoords/src/t_hpctran.x +images/imcoords/src/healpix.x +images/imcoords/src/mkpkg +images/imcoords/doc/hpctran.hlp +images/imcoords/hpctran.par +images/imcoords/imcoords.cl +images/imcoords/imcoords.hd +images/imcoords/imcoords.men +images/x_images.x + A new task to convert between HEALPix row and spherical coordinates. + Data access to a HEALPix FITS binary table can be done with the + TABLES package but being able to compute the row from a coordinate + was needed. (7/28/09, Valdes) + +images/immatch/src/imcombine/src/icombine.x + The earlier change 10/22/08 that closes the masks between each line + had an error that instead of doing this only after trying without + closing the masks it was doing it every time. + (7/21/09, Valdes) + +images/immatch/src/imcombine/src/icomb.gx + The data buffers were not initialized after a salloc which could + cause a arithmetic error when doing offset images. This came up + with mergeamps. (7/9/09, Valdes) + +images/immatch/src/imcombine/src/icsetout.x + To protect against wild errors in the offsets (usually from a problem + with the WCS) for making a stack a warning error occurs if the output + size exceeds 1Gpixels when offsets used. (6/11/09, Valdes) + +images/imcoords/src/t_ccsetwcs.x + The behavior described in the help when there is more than one image and + only one solution specified does not agree with the code. I changed the + code to agree with the help. (5/21/09, Valdes) + +images/imutil/src/nhedit.x +images/imutil/src/getcmd.x +images/imutil/nhedit.par +images/imutil/doc/nhedit.hlp + A "rename" parameter switch was added for renaming a keyword. The + value field is the new keyword name. (2/25/09, Valdes) + +images/immatch/src/imcombine/src/icombine.x + If the input images have "[0]" and the output is to list only then + the extension is stripped. This is to allow a grouping task to + output the parent images of mefs. (1/20/09, Valdes) + +images/immatch/src/imcombine/src/icgdata.gx + When keepids=yes (such as with weighting) and using the "novalue" masktype + the id array was not set causing errors in icaverage. + (1/5/09, Valdes) + +images/imutil/src/hedit.x + Fixed a problem in the he_gval() procedure in which the use of '$' + in a field name was causing the imgstr to always fail. Added a check + so the field name is queried witout the leading '$' (1/2/09, MJF) + +pkg/xtools/imfilter/src/runmed.x + Modified because of an argument change in an xtools/rmmed.x routine. + There was not functional change. (10/29/08, Valdes) + +images/immatch/src/imcombine/src/icemask.x +images/immatch/src/imcombine/src/icomb.gx +images/immatch/src/imcombine/src/icombine.x +images/immatch/src/imcombine/src/icsetout.x +images/immatch/src/imcombine/src/xtimmap.gx +images/immatch/src/imcombine/src/imcombine.h +images/immatch/src/imcombine/src/generic/xtimmap.com + More changes to optimize large number of image and memory behavior. + (10/23/08, Valdes) + +images/immatch/src/imcombine/src/xtimmap.gx + Debugging statements were added controled by an define at the top. + This allows watching when images are mapped and unmapped. + (10/22/08, Valdes) + +images/immatch/src/imcombine/src/icmask.x +images/immatch/src/imcombine/src/icmask.h +images/immatch/src/imcombine/src/icombine.x + If memory runs out not only is the image buffer size reduced but the + pixel masks (if used) are closed after each access. This may be + rather inefficient but was the simplest way to handle the fact that + masks are stored in memory and can't easily be buffered in line + blocks. (10/22/08, Valdes) + +images/immatch/src/imcombine/src/icaclip.gx + When too many pixels are rejected the operation of adding back some + pixels would clobber the sigma value; i.e. reuse of a variable still + in use. (10/13/08, Valdes) + +images/immatch/src/imcombine/src/icaclip.gx +images/immatch/src/imcombine/src/iccclip.gx +images/immatch/src/imcombine/src/icsclip.gx + When clipping about the median from below the rejection could + terminate early, because the wrong variable was used, resulting in + an incorrect value. I believe this will only be a problem when the + sigma factor is very small. (10/07/08, Valdes) + +======= +V2.14.1 +======= + +images/x_images.x +images/imutil/imutil.cl +images/imutil/imutil.hd +images/imutil/imutil.men +images/imutil/nhedit.par + +images/imutil/doc/nhedit.hlp + +images/imutil/src/nhedit.x + +images/imutil/src/getcmd.x + +images/imutil/src/mkpkg + Installed the NHEDIT task (HEDIT with comments) (8/19/08, MJF) + +images/immatch/doc/geomap.hlp +images/immatch/doc/geotran.hlp + Fixed some typos in the doc. (8/13/08, MJF) + +images$imutil/src/imexpr.gx + Quoted strings in the expression database were not being handle + correction. Specifically, the quotes were stripped and single + quotes were being parsed as character constants. + (8/12/08, Valdes) + +images$immatch/src/imcombine/src/ichdr.x + The PROCID keywords have not proven to be very meaningful. In the + interests of backwards compatibility, if imcmb=$I these keywords are + still written but otherwise they are not. + (7/23/08, Valdes) + +images$immatch/src/imcombine/src/ichdr.x +images$immatch/src/imcombine/imcombine.par +images$immatch/imcombine.par +images$immatch/doc/imcombine.hlp + A new parameter "imcmb" was added to control the value written to the + IMCMBnnn keywords in the output image. The value is a keyword in the + input images to be copied to the output IMCMBnnn keywords. The default + parameter value, "$I", is the basename input image name as before. + (7/22/08, Valdes) + +images$imutil/src/t_imstat.x + The clipping calculation was resetting the user supplied pixel limits. + Instead, any clipping limits need to remain bounded by the user + limits. + (7/15/08, Valdes) + +images$imfilter/runmed.par +images$imfilter/doc/runmed +images$imfilter/src/t_runmed.x +images$imfilter/src/runmed.x +images$imfilter/src/rmmed.x - + 1. rmmed.x was moved to xtools. + 2. A new parameter, nclip, was added to allow clipping of high values + from the running median. + (2/29/08, Valdes) + +images$immatch/src/imcombine/t_imcombine.x +images$tv/imexamine/ievimexam.x + Fixed some procedure calls closed with a ']' instead of ')' (02/17/08, MJF) + +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/icgdata.gx +images$immatch/src/imcombine/src/icaverage.gx +images$immatch/src/imcombine/src/iclog.x +images$immatch/src/imcombine/src/icmedian.gx +images$immatch/src/imcombine/src/icomb.gx +images$immatch/src/imcombine/src/icombine.h + 1. Added a new "masktype" option called "novalue". This uses 0 for + good pixels, "maskvalue" for pixels with no data, and any other value + for bad pixels. When there is no overlapping good data the blank + value is used if all the pixels are no data and otherwise the + image pixel values are combined as if good. The output mask will + have 0 for good, 1 for no data, and 2 for data based on bad data. + 2. The "masktype" option can now be "! " to specify + both a keyword for the mask and any mask type method. + (2/11/08, Valdes) + +images$imcoords/src/t_ccfind.x + When using a ZPN projection, the transform code in mwcs tries to + reference the parent image to get the PV matrix keywords. This task + called sk_decwcs() to open the WCS, but for an image it then unmapped + the image. When the task later uses the 'mw' pointer to transform coords + the ZPN reference to the parent image is invalid and results in a + segfault. Changed the code to call sk_decim() directly and operate on + the currently open image instead. (1/23/08, MJF) + +images$imcoords/src/t_ccmap.x +images$immatch/src/psfmatch/rgpsfm.x +images$imutil/src/t_imtile.x +images$tv/imexamine/t_imexam.x + Fixed various type declaration problems (1/21/08, MJF) + +images$immatch/src/imcombine/icmask.x + Changes to support the pmmap features of mask matching. (1/21/08, Valdes) + +images$immatch/src/imcombine/src/ichdr.x + When recording the images combined only the basename is now used. + (1/21/08, Valdes) + +images$immatch/src/imcombine/src/icombine.x +images$immatch/src/imcombine/t_imcombine.x + Added a listonly argument. This is not currently used by IMCOMBINE but + is used in other packages sharing this library. (1/21/08, Valdes) + +images/lib/rgtransform.x +image/immatch/src/listmatch/t_xyxymatch.x + Changed the name of the rg_intersect() function to rg_intersection() + to avoid a possible conflict with an xtools procedure of the same + name. (1/16/08, MJF) + +images$tv/imed.par + Added entries for missing minvalue/maxvalue params (1/14/08, MJF) + +images$immatch/src/geometry/t_geomap.gx + Changed the output precision of the rotation angles from 3 to 5 + decimal places. (1/14/08, MJF) + +images$imfilter/src/runmed.x + Modified to use yt_mappm for the input mask. The default is still to + work in logical coordinates but now the user can set "pmmatch=world" + to match masks in world coordinates to efficiently implement the + dimsum approach to second pass sky subtraction. + (1/9/08, Valdes) + +===== +V2.14 +===== +images$imfilter/src/rmmed.x + A data structure was allocated with a wrong length (too short) resulting + in the possiblity of a segmentation violation. (1/18/07, Valdes) + +images$immmatch/src/imcombine/src/icgdata.gx + The optimization for large numbers of offset images which don't + overlap (such as a strip of exposures) caused problems with + offsets on 3D images. The optimization was made to apply only + with 1D or 2D output images. (10/20/06, Valdes) + +images$immmatch/src/imcombine/src/icomb.gx + The addition of the sum option failed to add a case for selecting how + to set the keepids flag. Add SUM to the switch on line 229. + (2/28/06, Fitzpatrick, Valdes) + +images$imcoords/src/mkcwcs.cl + I can't remember if there was a reason for the first two hedit calls. + But if a new image is being created these calls cause a warning error. + The safest way to address this without remember if there is a reason + for the statements is to put them inside a block that is executed only + if the image exists. (1/27/06, Valdes) + +images$imcoords/src/mkcwcs.cl + +images$imcoords/src/mkcwwcs.cl + +images$imcoords/doc/mkcwcs.hlp + +images$imcoords/doc/mkcwwcs.hlp + +images$imcoords/imcoords.cl +images$imcoords/imcoords.men +images$imcoords/imcoords.hd + Two new tasks were added to create or modify simple and standard + celestial and celestial/wavelength WCS. The parameters are designed + to make it simpler for a user to specify WCS information in a + natural way without understanding the details of the WCS structure. + The tasks may be used to make data-less WCS for templates or to + add or update a WCS in an image. These scripts depend on the + changes to WCSCOPY and WCSEDIT which are the underlying interfaces + to the WCS. + (6/24/05, Valdes) + +images$imcoords/src/t_wcsedit.x +images$imcoords/wcsedit.par +images$imcoords/doc/wcsedit.hlp + Modified to allow a new data-less WCS header to be created of + dimensionality given by the new parameter "wcsdim". + (6/23/05, Valdes) + +images$immatch/src/wcsmatch/t_wcscopy.x +images$immatch/doc/wcscopy.hlp + Modified to allow creation of a new data-less WCS header. Also checking + on image sizes and dimensionality was commented out. + (6/23/05, Valdes) + +======= +V2.12.3 +======= + +images$imfilter/src/t_runmed.x +images$imfilter/src/runmed.x +images$imfilter/src/rm_med.x +images$imfilter/src/mkpkg +images$imfilter/runmed.par +images$imfilter/doc/runmed.hlp +images$imfilter/imfilter.cl +images$imfilter/imfilter.hd +images$imfilter/imfilter.men +images$x_images.x + Installed new running median task. (5/6/05, Valdes) + +images$imcoords/src/t_ccsetwcs.x + The option to specify a list of images with a single plate solution + record, as described in the help, was not working. This was fixed. + (10/8/04, Valdes) + +images$immatch/src/wcsmatch/t_wcscopy.x + Removed a check that would not allow dataless WCS to be copied. + (8/25/04, Cooke & Valdes) + +images$imutil/src/imgets.x + Modified so that strings with double quotes can be accessed. + (7/27/04, Valdes) + +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/iclog.x +images$immatch/src/imcombine/src/imcombine.h +images$immatch/src/imcombine/imcombine.par +images$immatch/imcombine.par + As a special unadvertised feature the "maskvalue" parameter may be + specified with a leading '<' or '>'. Ultimately a full expression + should be added and documented. (7/26/04, Valdes) + +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/Revisions + + Added a feature to allow masks specified without a path to be found + either in the current directory or the directory with the image. This + is useful when images to be combined are distributed across multiple + directories. (7/16/04, Valdes) + +======== +V2.12.2a +======== + +images$immatach/src/imcombine/src/icgdata.gx + Offset one-dimensional images do not combine correctly because the + imgnl routines reset the index counter for the first element in + this case. This index counter was being used assuming only the + second dimension would increment; i.e. images were at least 2D. + (4/8/04, Valdes) + +images$imutil/src/hedit.x + The task could segfault when initializing/adding a new keyword with a + null value. The evexpr operator was being initialized as a scalar and + the string pointer wasn't allocated, added a check so string pointer + is always allocated to at least one char. (3/23/04, MJF) + +images$imcoords/src/t_wcsctran.x + If the image dimensionality is zero then use the WCS dimensionality. + (3/15/04, Valdes) + +images$imcoords/src/t_wcsctran.x + An error in mw_openim was trapped but the garbage in the return value + caused a segmentation error during error recovery. A fix was made to + this and also to report, as a comment, the MWCS error. + (3/12/04, Valdes) + +======= +V2.12.2 +======= + +images$immatch/src/imcombine/src/xtimmap.gx + The change for the short image name from 8/20/03 was lost. This + change restores it. (2/3/04, Valdes) + +images$immatch/src/imcombine/src/xtimmap.gx + Copying the IMIO structure to an internal structure required two + amovi calls in order to maintain alignment. (2/12/04, Zarate/Valdes) + +images$immatch/src/geometry/t_geoxytran.x +images$immatch/src/geometry/trinvert.x + +images$immatch/src/geometry/mkpkg +images$immatch/geoxytran.par +images$immatch/doc/geoxytran.hlp + A new parameter "direction" was added to GEOXYTRAN to allow evaluating + the transformation in either the forward direction (the previous behavior + and default with the new parameter) or the backward direction. The + help page was updated to describe this new feature and address confusion + over the relationship between geomap, geotran, and geoxytran. + (2/7/03, Valdes) + +images$immatch/imalign.cl + Restructured to avoid goto statements, no functional changes (12/29/03, MJF) + +images$lib/geomap.gx + Small change to improve stability. Instead of checking the value + of the difference of two large numbers for zero, the equality of + the two numbers is checked. (10/29/03, Valdes) + +images$immatch/src/imcombine/src/xtimmap.gx + Increase the stored filename length. (8/20/03, Valdes) + +images$immatch/src/imcombine/src/icsetout.x + When using offsets based on physical coordinates and there is a flip + the routine was incorrectly using imunmap instead of xt_imunmap. + (7/30/03, Valdes) + +images$immatch/src/imcombine/src/icstat.gx + Fixed an incorrect declaration for asum$t() in the generic routine. + This is the correct fix for: + images$immatch/src/imcombine/src/generic/icstat.x + Fixed an incorrect declaration for asumd() (7/8/03, MJF) + (7/30/03, Valdes) + +images$imgeom/src/t_imshift.x + Fixed and incorrect declaration for clgetd() (7/8/03, MJF) + +images$tv/imexamine/stfprofile.x + The selection of a point to get a first estimation of the FWHM in + stf_fit did not check for the case of a zero value. This could cause + a floating divide by zero. (5/5/03, Valdes) + +images$tv/imexamine/stfprofile.x + The subpixel evaluation in stf_profile involves fitting an image + interpolator to a subraster. To avoid attempting to evaluate a point + outside the center of the edge pixels, which is a requirement of the + image interpolators, the interpolator is fit to the full data raster + and the evaluations exclude the boundary pixels. (5/5/03, Valdes) + +images$tv/imexamine/stfmeasure.x +images$tv/imexamine/stfprofile.x + +images$tv/imexamine/mkpkg.x + Separated the routines in stfmeasure.x to correspond to those used + in OBSUTIL. (5/6/03, Valdes) + +images$immatch/src/imcombine/src/icombine.x + Due to the way IMIO works it converts an out of memory error to + cannot open pixel file if a memory alloaction error occurs when + allocating file descriptor memory. So if this error occurs and the + number of images is small the error will be interpreted as + a memory allocation error. (4/9/03, Valdes) + +images$tv/display/dspmmap.x + Added errchk's for im_pmmapo to avoid the potential for a segmentation + violation due to an uncaught error. (9/16/02, Valdes) + +images$imgeom/src/t_imshift.x + An incorrect shift of one pixel would appear when the specified shift + was near zero and less than the precision of a real; i.e. yshift=1e-9. + The code was changed to use double precision as appropriate. + (9/12/02, Valdes) + +images$tv/imexamine/iemw.x + Added a heuristic check for the appropriate hHmM formats. + (9/12/02, Valdes) + +images$tv/display/dspmmap.x + A common case of matching a mask to an image is where the pixel sizes + are the same but there are offsets and/or different sizes. An optimized + mask matching based on using range lists and not calling mwcs was + added. (9/12/02, Valdes) + +images$tv/display/dspmmap.x + The matched mask was incorrectly returning the input mask when the + scale and offset matched but not the size. (9/10/02, Valdes) + +images$imutil/src/imrep.gx + In imrepr$t there was a declaration error for ilower. (see buglog #507) + (9/4/02, Valdes/Warner) + +images$immatch/src/listmatch/t_imctroid.x + Added a F_FLUSHNL for the standard output to avoid having the warnings + printed with eprintf from occuring in the middle of the output + lines. This caused a problem in imalign when scanning the lines. + (8/19/02, Valdes) + +======= +V2.12.1 +======= + +images$immatch/src/imcombine/src/iclog.x + The pixel masks listed in the log output was wrong. This only applies + to the log, the correct mask is used during processing. (6/26/02, Valdes) + +pkg/images/src/xregister/t_xregister.x +pkg/images/src/xregister/rgxicorr.x + If the xregister task parameter interactive = yes and the output images + are defined then the computed shifts are not applied. This occurs because + the reinitialization routine triggered by the 'n' keystroke command is in + the wrong place. The work around is to run xregister twice, once + interactively to compute the shifts, and again non-interactively to + apply them. (6/20/02, Davis) + +images$immatch/src/imcombine/src/icsetout.x + Needed to disable axis mapping to handle cases where the input + images are dimensionally reduced. (6/14/02, Valdes) + +images$immatch/src/imcombine/src/xtimmap.gx + The size of image header data structures was computed incorrectly + resulting in the potential for segmenation violations. (6/14/02, Valdes) + +===== +V2.12 +===== + +images$imutil/src/t_imstat.x + If nclip > 0 and the initial mean and standard deviation are INDEF + (a very unlikely occurence unless there is a mask) the k-sigma + limit computation in the imstatistics task could overflow. This does + not affect released code. (5/01/02, Davis) + +images$immatch/src/imcombine/src/icmask.x + The fix of 4/8/02 had been inadvertently undone. (4/25/02, Valdes) + +images$imutil/src/imadiv.gx +images$imutil/src/generic.imadiv.x + Fixed an error in the code which evaluates an expression of the form + "inimage / 0" which was causing a bus error on the macosx but not on + solaris. This error has apparently been there for ever. (4/24/02, Davis) + +images$immatch/src/imcombine/t_imcombine.x +images$immatch/src/imcombine/src/icombine.x +images$immatch/src/imcombine/src/icsetout.x +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/iclog.x + The projection option was no longer working. There was a typo in + t_imcombine.x, the dimensionality of the image was not set + properly in icombine.x and icsetout.x, and the masks for projected + images was not correct. (4/22/02, Valdes) + +images$immatch/src/imcombine/src/icsetout.x + When computing offsets the registration point was the reference pixel + returned by mw_gwterm for the first image. The code then went on to + assume this was a logical pixel when comparing with the other images, + which is not true when there is a physical coordinate system. The + algorithm was fixed by converting the reference point to logical + coordinates. (4/18/02, Valdes) + +images$imcoords/src/t_ccget.x + Ccget was not transforming the units and applying the user supplied + formatting parameters if the input or output coordinate system, e.g. + ICRS, was the same as the catalog coordinate system. This does not + affect released code. (04/16/02, Davis) + +images$immatch/src/imcombine/src/icmask.x + There was a bug in the recent change to open and close masks as needed + where a possibly null filename pointer was being checked for being + a null string. (4/8/02, Valdes) + +images$imcoords/src/t_wcsctran.x + Added a check for INDEF valued input coordinates. (4/04/02, Davis) + +images$tv/imexamine/iegimage.x + Image sections in the image name retrieved from the display server + are now handled more intelligently. In particular, 2D sections of + higher dimensional images will now examine the correct 2D section + rather than just the lowest 2D plane. (3/20/02, Valdes) + +images$tv/display/t_display.x + If an image section of a higher dimensional image is displayed the + image section is included in the image name sent to the display + server. Previously the section was stripped and so it was not + possible to know the 2D section displayed. For now we keep backwards + compatibility by stripping any section from 2D parent images. + (3/20/02, Valdes) + +images$immatch/src/imcombine/src/icombine.x + Added error checks for imunmap of the output files. In the final + staage of closing the output if an error occurs, principally in + writing mask, this will at least allow the primary combined output + image to be written. This is useful when an extremely large combining + operation is performed. (3/6/02, Valdes) + +images$immatch/src/imcombine/src/iclog.x +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/icstat.gx + Rather than open all the masks at the beginning the masks are now + opened and closed as needed. For situations with offsets this + can reduce the amount of memory required for the masks. + (3/6/02, Valdes) + +images$/imutil/src/hselect.x +images$/imutil/src/hedit.x + Added missing xev_freeop calls to the hedit and hselect tasks and a missing + mfree call to the hselect task. (3/5/02, Davis) + +images$tv/imexamine/iegimage.x + When imexmaine fails to map the image name returned by the display server + it uses the frame buffer. Previously there was no warning message about + failing to map the image. Now there is a warning. This is only given + once until the image name is changed either by going to a new frame + buffer or doing a new display. (3/4/02, Valdes) + +images$tv/imexamine/iegimage.x +images$tv/imexamine/t_imexam.x + When the frame buffer is used as the image source (when the image name + in the display frame cannot be mapped) the final imunmap woutd + attempt to unmap the same descriptor twice. (3/1/02, Valdes) + +images$imcoords/src/t_wcsctran.x + Fixed a bug the logical to tv coordinate mapping which could occur + if the section subsmapling parameter was > 1, the input image was a section + of a higher dimensioned image, and the first dimension was not one + of those extracted. (3/1/02, Davis) + +images$tv/imexamine/iegimage.x + The 'p' was not properly updated for the multiple WCS changes. + (2/26/02, Valdes) + +images$immatch/src/imcombine/src/xtimmap.gx + The header keywords were not being fully copied. (2/20/02, Valdes) + +images$immatch/src/imcombine/src/icstat.gx +images$immatch/src/imcombine/src/xtimmap.gx + asum$t declared incorrectly as type PIXEL rather than real. xt_cpix + incorrectly defined as pointer function instead of a subroutine. + (2/20/02, Valdes) + +images$imutil/src/t_minmax.x + Fixed a floating overflow error in minmax which occurred if the + dimensionality of the input image was 0 and the update parameter + was set to yes. In this case the min and max values were set to + INDEF (min and max computation is done internally in double precision) + could not fit into the real valued min and max slots in imhdr.h + hence the conversion error. (2/19/02, Davis) + +images$tv/imexamine/iegimage.x + The changes to support multiple WCS per frame involved keeping track of + the full WCS frame id (i.e. 101) rather than just the frame number. + There was a minor error in this bookkeeping when incrementing the + the next display frame to be used. (2/19/02, Valdes) + +images$lib/imcopy.x + Added a missing sfree statement to the img_imcopy routine. (2/18/02, Davis) + +images$immatch/src/imcombine/src/icaverage.x +images$immatch/src/imcombine/src/icsigma.x +images$immatch/src/imcombine/src/icomb.gx +images$immatch/src/imcombine/src/icscale.x +images$immatch/src/imcombine/src/icemask.x +images$immatch/doc/imcombine.hlp + If weights of zero are given for an image then that image will not + contribute to the output weighted average unless all of the + non-excluded images have zero weight. In that case the unweighted + average is output. The exposure mask is the sum of the exposure times + of the images with non-zero weights. These changes allow combining + only data which is considered good (photometric or good seeing) as + specified by the weights but still including non-good data in the + final image when there is no good data. The combinined zero weight + data will have an exposure time mask value of zero. (2/8/02, Valdes) + +images$immatch/src/imcombine/src/icmask.x +images$immatch/src/imcombine/src/icmask.h +images$immatch/src/imcombine/src/iclog.h +images$immatch/src/imcombine/imcombine.par +images$immatch/imcombine.par +images$immatch/doc/imcombine.hlp + The masktype parameter may now specify ! to select the keyword + to use for a mask. When this option is selected the mask value + interpretation is "goodval". (2/5/02, Valdes) + +images$immatch/src/imcombine/src/icmask.x + If pl_loadf fails then pl_loadim is tried. This adds support for + masks in FITS extensions. (2/5/02, Valdes) + +images$tv/display/dspmmap.x + Added the feature that the bad pixel mask or overlay mask may be + specified by a keyword value with the syntax !. This is + important for multiextension files where various masks are set + as keywords. The new task OBJMASKS also writes the object mask name + that is created for an image in the header. Use of !objmask then + allows the object mask to be used for the bad pixel mask (to set + the scaling using only sky pixels) and for overlay. + (2/5/02, Valdes) + +images$tv/display/sigm2.x + The routine to compute the maximum value as the interpolated quantity + was incorrect because the size of the input and output arrays were + treated as the same when they are not. This is used for overlay + display which produced the symptom of horizontal lines. + (2/5/02, Valdes) + +images$immatch/src/imcombine/src/icombine.x +images$immatch/src/imcombine/src/icomb.gx +images$immatch/src/imcombine/src/xtimmap.gx +images$immatch/src/imcombine/src/icombine.h + The buffer size management calculation based on the number of input + images was no longer working because unless IM_BUFFRAC is explicitly + set to 0, the requested buffer size is just a lower limit. The buffer + size calculation was modified and calls to set IM_BUFFRAC to zero were + added. (1/30/02, Valdes) + +images$immatch/src/imcombine/src/xtimmap.gx +images$immatch/src/imcombine/src/icomb.gx +images$immatch/src/imcombine/src/icgdata.gx + The code to close unused images when they are not needed had an error + when there were y offsets. Rather than closing each image when it not + longer contributed to an output line due to an offset, it was instead + closing all images on every line and then mapping them again. + (1/29/02, Valdes) + +images$imutil/src/t_minmax.x + Removed extra arguments from the calls to clpstr. (01/07/02, Davis) + +images$imutil/src/t_imstat.x + Added a call setting IM_BUFFRAC to 0 to the memory caching code in the + imstatistics task in order to force the imio buffer to be the size of + the input image. + (12/10/01, Davis) + +images$imcoords/src/t_wcsctran.x +images$imcoords/src/rgstr.gx +images$imcoords/src/rgstr.x + Wcsctran may produce a string_file error if the input image is + dimensionally reduced. The problem was caused by an uninitialized + array. The code works ig by chance the array is initialized to 0. + (12/8/01, Davis) + +images$immatch/src/imcombine/src/icscale.x + Fixed bug with normalization. (12/4/01, Valdes) + +images$imutil/src/hedit.par +images$imutil/doc/hedit.hlp +images$imutil/src/hedit.x + For backwards compatability modified the precedence of the operator + switches from addonly / add / delete to add / addonly / delete. + Also clarified the switch precedence rules in the help page. + (11/13/01, Davis) + +images$imutil/src/imheader.x + Fixed imheader so it prints out an image size of 0 if IM_NDIM(im) is + is 0 instead of the contents of the first element of the IM_LEN(im,1) + vector which may be non-zero. (11/05/01, Davis) + +images$immatch/src/xregister/rgxicorr.x +images$immatch/src/xregister/rgxcolon.x +images$immatch/src/xregister/rgxtools.x + Fixed a bug in the xregister multiple region handling code that was + preventing xregister from computing x-correlations on regions beyond + the first in interactive mode. (10/17/01, Davis) + +images$imcoords/src/t_skyctran.x +images$imcoords/src/t_sffind.x +images$imfilter/src/mode.x +images$imutil/doc/hedit.hlp +images$imutil/doc/imdivide.hlp +images$tv/doc/Tv.hlp +images$tv/iis/doc/Cv.hlp +images$tv/iis/doc/cv.hlp +images$tv/iis/ids/doc/Imdis.hlp +images$immatch/src/imcombine/t_imcombine.x + Fixed various missing/extra argument problems in the images package + code that were found with spplint. Also fixed miscellaneous help page + formatting problems. (9/19/01 Davis) + +images$imutil/src/t_imjoin.x + Changed the clgetc call to clgstr calls for the pixtype parameter in + imjoin. This change is required to avoid an "ERROR: Parameter not a legal + character constant (parname)" error introduced by recent changes to the CL. + Basically "" is no longer a legal argument for clgetc. (9/17/01 Davis) + + +images$imutil/imstatistics.par +images$imutil/doc/imstatistics.hlp +images$imutil/src/imstat.h +images$imutil/src/t_imstat.x + 1. Added an interative rejection capability to the imstatistics task. + 2. Added a cacheing option that can speed up the performance of the + task if the midpt/mode statistic is computed or if iterative rejection + is performed. + (8/30/01, Davis) + +images$immatch/src/imcombine +images$immatch/src/imcombine/src + + 1. Further modifications and optimizations. + 2. Reorganized with a subdirectory of common routines shared with + the CCD reduction versions. + (8/29/01, Valdes) + +images$immatch/src/imcombine +images$immatch/imcombine.par +images$immatch/doc/imcombine.hlp + 1. New parameters "headers", "bpmasks", "rejmasks", "nrejmasks", + and "expmasks" provide additional types of output. The old + parameters "rejmask" and "plfile" were removed. The new + "nrejmasks" parameter corresponds to the old "plfile" and the + new "rejmasks" parameter corresponds to the old "rejmask". + 2. There is a new "combine" type "sum" for summing instead of + averaging the final set of offset, scaled, and weighted + pixels. + 3. There is a new parameter "outlimits" to allow output of a + subregion of the full output. This is useful for raster + surveys with large numbers of images. + 4. Additional keywords may appear in the output headers. + 5. The scaling is now done relative to the first image rather than + an average over the images. This is done so that flux related + keywords such as exposure time and airmass remain + representative. + 6. The environment parmaeter "imcombine_option" allows using an + algorithm that opens and closes images. This is very slow but + allows combining large numbers of images which are not the same + size. + 7. New help page. + (8/17/01, Valdes) + +tv$imexamine/iecimexam.x +tv$imexamine/ieeimexam.x +tv$imexamine/iegcur.x +tv$imexamine/iegimage.x +tv$imexamine/iegnfr.x +tv$imexamine/iehimexam.x +tv$imexamine/ieimname.x +tv$imexamine/iejimexam.x +tv$imexamine/ielimexam.x +tv$imexamine/ieopenlog.x +tv$imexamine/ieqrimexam.x +tv$imexamine/ierimexam.x +tv$imexamine/iesimexam.x +tv$imexamine/ietimexam.x +tv$imexamine/ievimexam.x +tv$imexamine/imexam.h +tv$imexamine/t_imexam.x + Modifications to use multiple WCS mappings. (8/13/01, Valdes) + +tv$imexamine/mkpkg +tv$imexamine/x_imexam.x + +tv$imexamine/imexamine.par + + Added a mkpkg target to compile standalone; i.e. mkpkg standalone. + (8/13/01, Valdes) + +immatchx$src/ximcoords/t_ccmap.x + Fixed a bug in the ccmap refpoint = "coords" option that could produce a + totally inaccurate reference point estimate if the image spanned 0 + hours right ascension due to coordinate wrap around. (7/20/01 Davis) + + +images$imgeom/src/t_magnify.x + Fixed a bug in the magnify task that can cause a previous block of lines + to be repeated instead of a new block computed. This bug was introduced + when magnify was upgraded to use the new interpolants code and to use + boundary extension in imio. A typo was made in the update which produces + the error in the case where the buffer does not update when a new group of + lines is computed. This situtation is not normally supposed to occur + but may in the situation where the magnification factors are greater than + the internal buffer size of 16 output image lines. (6/21/01, Davis) + +images$immatch/src/imcombine/t_combine.x +images$immatch/src/imcombine/icombine.gx +images$immatch/src/imcombine/icgdata.gx +images$immatch/src/imcombine/icscale.x +images$immatch/src/imcombine/xtimmap.x + +images$immatch/src/imcombine/mkpkgx + When combining more images than there are IRAF FIO descriptors the + additional images are mapped and unmapped as needed. There is no + limit now on the number of images or that they be capable of being + stacked into a single image for combining by projection. The creation + of a temporary stack image is no longer done. (6/16/01, Valdes) + +images$immatch/src/psfmatch/rgpfilter.x +images$immatch/src/psfmatch/rgpconvolve.x + Fixed a floating point error in the replace algorithm gaussian fitting + routines that occurs if the argument to the log function is exactly zero. + Fixed a symmetry error in the convolve routine that would produce a + corrected psf that was flipped in x and y if the psf matching kernel + did not have mirror symmetry. The solution was simply to rotate the + convolution kernel 180 degrees before applying it to the input image. + The matching kernel itself is correctly oriented and can be used + directly with the fconvolve task. (5/15/01 Davis) + +images$imutil/hedit.par +images$imutil/doc/hedit.hlp +images$imutil/src/hedit.hlp + Added a new addonly parameter to the hedit task. If addonly is set + a new field will only be added to the image header if it does not + already exist. (4/30/01, Davis) + +images$tv/display/dspmmap.x + Fixed problems with ds_match. The new version is more robust and + correct. A bad pixel for the displayed image is the maximum of all + pixels in the pixel mask which fall within the display pixel. This + version still does not allow any relative rotations but does allow + non-integer offsets. (4/24/01, Valdes) + +images$imgeom/src/t_im3dtran.x +images$imgeom/src/t_imtrans.x +images$imgeom/src/t_imshift.x +images$imgeom/src/t_magnify.x + Modified the im3dtran, imtranspose, imshift, and magnify tasks so that + the output image which is mapped NEW_COPY is closed before the input image. + To the best of my knowledge this has not caused problems to date but + it could (3/1/01 Davis) + +images$immatch/src/imcombine/icsetout.x + The physical coordinates of the output WCS are now reset. + (3/1/01 Valdes) + +images$lib/geomap.h +images$lib/geogmap.h +images$lib/geofit.gx +images$lib/geofit.x +images$lib/geogmap.gx +images$lib/geogmap.x +images$lib/geograph.gx +images$lib/geograph.x +images$lib/geomap.key +images$lib/coomap.key +images$immatch/geomap.par +images$immatch/doc/geomap.hlp +images$immatch/src/geometry/t_geomap.gx +images$immatch/src/geometry/t_geomap.x +images$imcoords$ccmap.par +images$imcoords/src/t_ccmap.x +images$imcoords/doc/ccmap.hlp + + Added a new parameter maxiter to the geomap and ccmap tasks. Maxiter + defines the maximum number of rejection iterations and has a default + value of 0 for no rejection. + + Changed the default value of the ccmap and geomap parameter reject from + INDEF to 3.0. (05/01/01 Davis) + +pkg/images/imcoords/ + Added the tasks CCGET and CCSTD to the image package. (10/12/00 Davis) + +pkg/images/imcoords/src/t_ccmap.x +pkg/images/immatch/src/geometry/t_geomap.gx +pkg/images/immatch/src/geometry/t_geomap.x +pkg/images/lib/geomfit.gx +pkg/images/lib/geomfit.x +pkg/images/lib/geogmap.gx +pkg/images/lib/geogmap.x +pkg/images/lib/geogmap.h +pkg/images/lib/geogragh.gx +pkg/images/lib/geograph.x +pkg/images/lib/geomap.key +pkg/images/lib/coomap.key + Added a :order command to ccmap and geomap so that the user can change all + the orders at once. (10/12/00 Davis) + + Modified the error checking to fix a segvio problem which occured in ccmap + and geomap if the number of points was too few for a good fit and verbose + was set to no. (10/12/00 Davis) + +pkg/images/imcoords/imcctran.par +pkg/images/imcoords/src/t_imcctran.x +pkg/images/imcoords/doc/imcctran.hlp + Added support for doing coordinate transformations accurately on + images with non-zenithal projections where rotating the CD matrix + does not work accurately. + + Added a new parameter longpole to the imcctran task. If longpole =yes + then coordinate transformations with zenithal projections will be + rotated using longpole rather than the CD matrix. (2/7/00 Davis) + +pkg/images/immatch/ +pkg/images/imcoords/ + The immatch and imcoords packages were modified to use the new version + of the skywcs routines in xtools. (10/12/00, Davis) + +pkg/images/immatch/imcentroid.par +pkg/images/immatch/imalign.par +pkg/images/immatch/imalign.cl +pkg/images/immatch/doc/imcentroid.hlp +pkg/images/immatch/doc/imalign.hlp +pkg/images/immatch/src/listmatch/t_imctroid.x +pkg/images/immatch/src/listmatch/mkpkg + Added a new parameter maxshift to the imcentroid and imalign tasks. + Maxshift is the maximum permitted difference between the computed and + predicted shifts. Maxshift can be used to reject objects whose centers + have wandered too far from the expected center. By default maxshift is + undefined. (10/9/00, Davis) + +pkg/images/imcoords/src/sffind.x +pkg/images/imcoords/doc/starfind.hlp + Modified the way starfind computes the background estimate used to compute + the first and second order moments so that it does not depend on the + value and density of the central pixel. (10/9/00, Davis) + +pkg/images/immatch/src/imcombine/t_imcombine.x + Modified the conversion of pclip from a fraction to a number of images + because for even number of images the number above/below the median + is one too small. (9/26/00, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x +pkg/images/immatch/src/imcombine/icimstack.x + Error handling when running out of memory with immap (due to a very + large min_lenuserarea) and when trying to stack was fixed up to + report reasonable error messages and to not go into an infinite loop + trying to manage memory. (9/13/00, Valdes) + +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/src/imcombine/icgdata.gx + Additional errchk declarations were needed to catch out of memory + during image reading which were not caught during the initial + pass at reading the images. (9/11/00, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x + When a "cannot open image" error occurs for some other reason than + running out of file descriptors the task would go into an infinite + loop or given a segmentation error. The checking was improved to + avoid this. (8/31/00, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x + When there is an output mask or sigma image and the number of images + exceeds the maximum number allowed by the number of logical file + descriptors the task failed to delete the files when starting over + using the stacked image approach. This would result in an image + already exists error. This was fixed by deleting the files upon + error recovery. (8/9/00, Valdes) + +pkg/images/immatch/src/imcombine/mkpkg +pkg/images/immatch/src/imcombine/x_imcombine.x + +pkg/images/immatch/src/imcombine/imcombine.par + + Added a mkpkg entry to allow making the IMCOMBINE task independently + of the entire IMAGES package for testing and debugging purposes. + (6/21/00, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine. +pkg/images/immatch/src/imcombine/icimstack.x +pkg/images/immatch/src/imcombine/iclog.x +pkg/images/immatch/doc/imcombine.hlp + When there are a large number of images with bad pixel masks both the + input images and the bad pixel masks are stacked for combining. The + addition of stacking the masks allows for independent bad pixel masks + for each input image which was not supported previously. + (6/21/00, Valdes) + +pkg/images/immatch/src/imcombine/icmedian.gx + Replaced median algorithm with the faster Wirth algorithm. + (5/16/00, Valdes) + +pkg/images/lib/skywcs.x + Incorrect values for the epoch of observations were being computed + and printed by tasks like skyctran and imcctran if the input coordinate + system was read from an image and the input coordinate system was + galactic. The problem was that the epoch was being converted to MJD + twice instead of once. Unless a proper motion correction was being computed + this problem should have little practical effect although it is + disturbing to odd units in the file headers. (1/31/00, Davis) + +pkg/images/immatch/doc/imcombine.hlp +pkg/images/immatch/imcombine.par + The "outtype" parameter can take the value "none" in addition to one + of the standard datatypes. The help page was incorrect/unclear what + was meant by not specifying an output type. + (1/18/00, Valdes) + +pkg/images/immatch/src/imcombine/icgdata.gx +pkg/images/immatch/src/imcombine/iclog.x +pkg/images/immatch/src/imcombine/icmask.x +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/src/imcombine/icscale.x +pkg/images/immatch/src/imcombine/icsetout.x + Changed declarations for the array "out" to be ARB rather than 3 in + some places (because it was not changed when another element was added) + or 4. This will insure that any future output elements added will + no require changing these arguments for the sake of cosmetic correctness. + (1/13/00, Valdes) + +pkg/images/immatch/src/imcombine/icsetout.x + Fixed error with MWCS dimension mismatch when using offsets on + input images which have been dimensionally reduced. (1/12/00, Valdes) + +======== +V2.11.3a +======== +======= +V2.11.3 +======= + +pkg/images/imfilter/src/fmedian.x +pkg/images/imfilter/src/fmode.x +pkg/images/imfilter/src/frmedian.x +pkg/images/imfilter/src/frmode.x +pkg/images/imfilter/src/fmd_hist.x + Changed the fast median / mode histogram storage from short to int to + avoid overflows in the case that xfilter * yfilter > 32767 and > 32767 + pixels fall into a single bin as may happen in bad pixel regions. + (11/19/99, Davis) + +pkg/images/immatch/src/imcombine/icombine.gx + An input array was declared with a value of 3 though it was passed to + the routine with 4 elements. Later there was a reference to + the 4th element. While this is legal as the size in the declaration + is a dummy this was a compiler error on one platform. Changed the + declaration to 4. (11/19/99, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x + A call to IMUNMAP within the THEN clause of an IFERR replaces the + error string (inappropriately) so that a later ERRACT reports the + wrong error. The code was modified to get the error string before + calling IMUNMAP and then restores the error condition with an + ERROR call instead of an ERRACT. (10/21/99, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x + Modified error recovery to avoid a tranfer out of an IFERR block + message. (10/14/99, Valdes) + +pkg/images/immatch/doc/imcombine.hlp + Updated the expected number of images that can be combined without + stacking. (10/11/99, Valdes) + +pkg/images/imcoords/src/mkpkg +pkg/images/imgeom/src/mkpkg +pkg/images/immmatch/src/imcombine/generic/mkpkg +pkg/images/immmatch/src/imcombine/mkpkg +pkg/images/immmatch/src/imutil/generic/mkpkg +pkg/images/immmatch/src/imutil/mkpkg + Added some missing file dependencies and removed some uneccessary ones + from the mkpkg files. (9/21/99, Davis) + +======= +V2.11.2 +======= + +pkg/images/imutil/src/t_imarith.x + Added a check for division by zero in the header keywords. A warning + is printed, the keyword is not updated, and task completes without + aborting. (8/10/99, Valdes) + +pkg/images/imcoords/src/t_ccsetwcs.x +pkg/images/imcoords/src/ccxytran.x + Update the ccsetwcs and cctran tasks so they can deal correctly with the + zpx transformation. These tasks had been updated in immatchx but the + updates did not make it into the images versions of the tasks. + (Davis, June 26, 1999) + +pkg/images/imcoords/src/t_starfind.x + Modified the default output file naming code to deal rationally with + fits image extension names. + (Davis, June 26, 1999) + +pkg/images/lib/skywcs.h +pkg/images/lib/skywcs.x +pkg/images/imcoords/src/ttycur.key +pkg/images/imcoords/src/skycur.key +pkg/images/imcoords/doc/ccfind.hlp +pkg/images/imcoords/doc/ccmap.hlp +pkg/images/imcoords/doc/ccsetwcs.hlp +pkg/images/imcoords/doc/skyctran.hlp +pkg/images/imcoords/doc/imcctran.hlp + Added support for the ICRS system to the images.imcoords package. + (Davis, June 24, 1999) + +pkg/images/immatch/doc/geomap.hlp + Added some notes and an example to explain and illustrate the role of the + reference and input coordinates for different applicatons. i.e. image + resampling and coordinate transformation. + (Davis, June 18, 1999) + +pkg/images/immatch/src/geometry/t_geotran.x + Fixed a bug in the transform list decoding routine that was preventing + geotran from using the same transform for all the input images. + (Davis, June 18, 1999) + +pkg/images/immatch/src/imcombine/icsetout.x + Changed to better parse the offset types. The WCS correction for + offsets was incorrect. (6/17/99, Valdes) + +pkg/images/imcoords/src/t_wcsctran.x + Fixed a bug in the units initialization code. (Davis, June 3, 1999) + +pkg/images/imcoords/src/t_ccsetwcs.x + Improved the error message handling in the case when a database + records either not be found or could not be successfully decoded + in the ccsetwcs task. (Davis, June 3, 1999) + +pkg/images/immatch/src/geometry/geotran.x + Fixed a type mismatch problem in a call to max that was causing compilation + errors on the Dec Station. (Davis, June 2, 1999) + +pkg/images/immatch/doc/imcombine.hlp + Clarified whether the offset is done before scaling or afterword. + (5/18/99, Valdes) + +pkg/images/imcoords/doc/ccsetwcs.hlp +pkg/images/imcoords/doc/imcctran.hlp +pkg/images/imcoords/doc/skyctran.hlp +pkg/images/immatch/doc/skyxymatch.hlp + Added some information about the new DATE-OBS format to the help + pages for the ccsetwcs, imctran, skyctran, and skyxymatch tasks. + + (Davis, May 13, 1999) + +pkg/images/lib/skywcs.x + Added support for the new DATE-OBS format to the mwcs decoding routines. + All tasks in the imcoords and immatch packages which read the image wcs + will pick up the change. + + (Davis, May 13, 1999) + +pkg/images/immatch/src/listmatch/t_xyxymatch.x +pkg/images/imcoords/src/t_ccxymatch.x + Fixed the xyxymatch and ccxymatch tasks so that they work properly when + the number of reference files is greater than 1 and equal to the + number of input files. In that case xyxymatch and ccxymatch are supposed + to pair up the input and reference files one to one instead of using the + last file in the reference file list. + + (Davis, February 22, 1999) + +pkg/images/immatch/src/wcsmatch/t_wcscopy.x + Modified wcscopy to update the RADECSYS, EQUINOX, and MJD-WCS keywords + as well as the mwcs keywords. + (1/7/99, Davis) + +pkg/images/immatch/gregister.par +pkg/images/immatch/sregister.cl +pkg/images/immatch/wregister.cl +pkg/images/immatch/doc/gregister.hlp +pkg/images/immatch/doc/sregister.hlp +pkg/images/immatch/doc/wregister.hlp + Installed new versions of the gregister, sregister, and wregister tasks + (these tasks are scripts which call geotran) which support 1D and 2D + sinc and look-up table sinc interpolation and 2D drizzle resampling. + (12/29/98, Davis) + +pkg/images/imgeom/rotate.par +pkg/images/imgeom/imlintran.par +pkg/images/imgeom/doc/rotate.hlp +pkg/images/imgeom/doc/imlintran.hlp + Installed new versions of the rotate and imlintran tasks (these tasks are + scripts which call geotran) which support 2D sinc and look-up table sinc + interpolation and 2D drizzle resampling. + (12/29/98, Davis) + +pkg/images/immmatch/geotran.par +pkg/images/immatch/src/geometry/geotran.h +pkg/images/immatch/src/geometry/t_geotran.x +pkg/images/immatch/src/geometry/geotran.x +pkg/images/immatch/src/geometry/geotimtran.x +pkg/images/immatch/doc/geotran.hlp + Installed a new version of the geotran task which supports 1D and 2D + sinc and look-up table sinc interpolation and 1D and 2D drizzle resampling. + Simplified the code and modified the out-of-bounds pixel handling algorithm + to conform to the other image resampling tasks. Corrected a couple of bugs + in the 1D image resampling code. + (12/29/98, Davis) + +pkg/images/immatch/xregister.par +pkg/images/immatch/src/t_xregister.x +pkg/images/immatch/src/rgximshift.x +pkg/images/imgeom/doc/xregister.hlp + Installed a new version of the xregister task which supports 2D sinc and + look-up table sinc interpolation and 2D drizzle resampling. + (12/29/98, Davis) + +pkg/images/imgeom/shiftlines.par +pkg/images/imgeom/src/t_shiftlines.x +pkg/images/imgeom/src/shiftlines.x +pkg/images/imgeom/doc/shiftlines.hlp + Installed a new version of the shiftlines task which supports 1D sinc and + look-up table sinc interpolation and 1D drizzle resampling. + (12/28/98, Davis) + +pkg/images/imgeom/imshift.par +pkg/images/imgeom/src/t_imshift.x +pkg/images/imgeom/doc/imshift.hlp + Installed a new version of the imshift task which supports 2D sinc and + look-up table sinc interpolation and 2D drizzle resampling. + (12/28/98, Davis) + +pkg/images/imgeom/magnify.par +pkg/images/imgeom/src/t_magnify.x +pkg/images/imgeom/doc/magnify.hlp + Installed a new version of the magnify task which supports 1D and 2D + sinc and look-up table sinc interpolation and 1D and 2D drizzle resampling. + Modified the out-of-bounds pixel handling algorithm to conform to the + other image resampling tasks. + (12/28/98, Davis) + +pkg/images/immatch/src/imcombine/icsetout.x + Fixed a problem with input images that have dimensional reduction. + (10/6/98, Valdes) + +pkg/images/imutil/src/t_imarith.x + If noact = yes, IMARITH would fail with a segmentation violation. This + was occuring because the header updating code was trying to access + the output image which did not exist. (9/16/98, Davis) + +pkg/images/tv/imexamine/stfmeasure.x + The logic in STF_FIT for determining the points to fit and the point + to use for the initial width estimate was faulty allowing some bad + cases to get through. (7/31/98, Valdes) + +pkg/images/immatch/src/imcombine/icgdata.gx + Needed to initialize the number of pixels combined for the case where + there is initially no data. (7/29/98, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x +pkg/images/immatch/doc/imcombine.hlp + The internal calculation type was changed from the highest precedence + type of the input images to the highest of the input and output. + This allows setting the output type to be real to force computation + in real for integer input images. Not doing this could cause severe + truncation errors if the users specify there own scaling values. + (7/14/98, Valdes) + +pkg/images/tv/imedit/epix.h +pkg/images/tv/imedit/t_imedit.x +pkg/images/tv/imedit/epcolon.x +pkg/images/tv/doc/imedit.hlp + The temporary editing buffer image was made into a unique temporary + image rather than the fixed name of "epixbuf". (6/30/98, Valdes) + +pkg/images/tv/display/dspmmap.x + The steps to check if an image and mask have an integer relationship + (integer sampling and integer offsets) in their physical coordinate + systems could fail because real precision was not high enough + in MWCS transformation calls. Changed variables and MWCS calls + to double. (5/29/98, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/src/imcombine/ic_rmasks.x + +pkg/images/immatch/src/imcombine/ic_log.x +pkg/images/immatch/src/imcombine/mkpkg +pkg/images/immatch/imcombine.par +pkg/images/immatch/doc/imcombine.hlp + Added a new output which is a pixel mask identifying which pixel in which + input image is rejected or not included in the final output. + (5/15/98, Valdes) + +pkg/lib/geograph.gx +pkg/lib/geograph.x + Modifed the plot labels to say "reject =" instead of "sigrej = " to + maintain naming consistency with the reject parameter. + (2/23/98 LED) + +pkg/images/immatch/src/imcombine/icsetout.x + The updating of the WCS for offset images was not being done correctly. + (2/5/98, Valdes) + +pkg/images/immatch/src/imcombine/icgrow.gx +pkg/images/immatch/src/imcombine/icombine.gx + Modified algorithm for efficiency. (1/28/98, Valdes) + +pkg/images/immatch/src/imcombine/t_imcombine.x +pkg/images/immatch/src/imcombine/icaclip.gx +pkg/images/immatch/src/imcombine/iccclip.gx +pkg/images/immatch/src/imcombine/icgdata.gx +pkg/images/immatch/src/imcombine/icgrow.gx +pkg/images/immatch/src/imcombine/iclog.x +pkg/images/immatch/src/imcombine/icmm.gx +pkg/images/immatch/src/imcombine/icombine.com +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/src/imcombine/icpclip.gx +pkg/images/immatch/src/imcombine/icsclip.gx +pkg/images/immatch/imcombine.par + Changed the grow parameter to a real radius. (12/30/97, Valdes) + +pkg/images/immatch/src/imcombine/icgrow.gx +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/doc/imcombine.hlp + Added 2D grow capability. (12/30/97, Valdes) + +pkg/images/immatch/src/imcombine/icaverage.gx +pkg/images/immatch/src/imcombine/icmedian.gx +pkg/images/immatch/src/imcombine/icombine.gx +pkg/images/immatch/src/imcombine/generic/mkpkg + Added new argument to select whether to set values with no data to + a blank value. This allows the calling task to set values without + having them overridden with the blank value. (12/30/97, Valdes) + +pkg/images/immatch/src/imcombine/icmm.gx + Fixed a bug where the image IDs were not being kept. (12/30/97, Valdes) + +======= +V2.11.1 +======= + +pkg/images/immatch/src/linmatch/lsqfit.h +pkg/images/immatch/src/linmatch/rglscale.x +pkg/images/immatch/src/linmatch/rgliscale.x +pkg/images/immatch/src/linmatch/rglsqfit.x +pkg/images/immatch/src/linmatch/rglplot.x + Fixed several bugs in the linmatch bad region handling code. The + bad region flag was not being set if the input image regions were + partially of the image or the sizes of the input reference and input + regions were different image, the error status flag was not being correctly + set after a bad region was detected, and the linear least squares fits + were not being properly protected against bad data regions, and + non-physical data fits. The graphics routines were also changed + to force windowing around the good data points. (12/19/97, Davis) + +pkg/images/immatch/src/linmatch/rglscale.x + The linmatch task could produce a floating operand error if the fitting + algorithm was "mean", "median", or "mode", and one or more of the reference + image regions had a mean, median, or mode values of 0.0. (12/15/97, Davis) + +pkg/images/imutil/src/imcopy.x +pkg/images/lib/imcopy.x + There were two different versions of the imcopy.x file in the images + packages which were causing different behavior in the imcopy task. + Updated the version in the lib subdirectory and deleted the version in + imutil/src. (11/18/97, Davis) + + +pkg/images/imfilter/src/t_median.x +pkg/images/imfilter/src/t_mode.x + The constant for constant boundary extension was declared as in integer + instead of a real in the median and mode tasks causing an FPE error on + the Dec Alpha if the value could not be converted. A value of 0 for + constant would work correctly. (11/11/97, Davis) + +pkg/images/immatch/src/imcombine/t_imcombine.x + When using STF images the failure error when there are too many images + is SYS_IKIOPEN rather than the others that occur with OIF, etc. + Added this error code to be caught and have the program build a + stacked image to combine. (10/21/97, Valdes) + +pkg/images/immatch/src/imcombine/icscale.x +pkg/images/immatch/doc/imcombine.hlp + When the zero offsets or weights are specified in a file the weight + adjustment for differeing sky levels is not done. (10/3/97, Valdes) + +===== +V2.11 +===== + +pkg/images/imutil/src/t_imtile.x + Modified the imtile task to avoid a potential divide by zero error + in the range decoding software. This error was actually due to + an interface change to the xtools$ranges.x code, which has since been + changed back, but the potential for error was there. (8/22/97, Davis) + +pkg/images/imcoords/src/sffind.x + Fixed a type mismatch in the call to atan2. (8/18/97, LED) + +pkg/images/immatch/src/imcombine/t_imcombine.x + Fixed a segmentation violation caused by attempting to close the + mask data structures during error recovery when the error occurs + before the data structures are defined. (8/14/97, Valdes) + +pkg/images/imutil/src/imhistogram.x + Fixed a bug in the imhistogram and phistogram tasks that could cause + an invalid floating point operation if the image contained pixels + outside the valid integer range. (7/31/97, Davis) + +pkg/images/immatch/src/xregister/rgxcorr.x + Fixed a bug in xregister that could occur if: the correlation parameter + was set to "fourier" and one of the correlation regions was completely + off the input image. In this case all the region shifts following + the first bad one were being set to INDEF. (7/25/97, Davis) + +pkg/images/lib/skywcs.x + Modified the coordinates structure initialization routine to explictly set + the physical and logical axis maps on startup rather than leaving them + undefined. (6/16/97, Davis) + +pkg/images/immatch/wcsxymatch.par +pkg/images/immatch/wcsmap.cl +pkg/images/immatch/wregister.cl +pkg/images/immatch/doc/wcsxymatch.hlp +pkg/images/immatch/doc/wcsmap.hlp +pkg/images/immatch/doc/wregister.hlp +pkg/images/immatch/src/wcsmatch/t_wcsxymatch.hlp + Added the transpose parameter to the wcsxymatch, wcsmap, and wregister + task to permit users to force an image transpose in cases where the + image wcs does not contain enough information, e.g. axtype is undefined + or set to the same units. + (6/10/97, Davis) + +pkg/images/immatch/geomap.par +pkg/images/immatch/skymap.cl +pkg/images/immatch/wcsmap.cl +pkg/images/immatch/sregister.cl +pkg/images/immatch/wregister.cl +pkg/images/immatch/doc/geomap.hlp +pkg/images/immatch/doc/skymap.hlp +pkg/images/immatch/doc/wcsmap.hlp +pkg/images/immatch/doc/wregister.hlp +pkg/images/immatch/doc/sregister.hlp +pkg/images/immatch/src/geometry/geoxytran.gx +pkg/images/immatch/src/geometry/geoxytran.x +pkg/images/immatch/src/geometry/t_geomap.gx +pkg/images/immatch/src/geometry/t_geomap.x +pkg/images/immatch/src/geometry/t_geotran.x +pkg/images/immatch/src/psfmatch/rgpbckgrd.x +pkg/images/immatch/src/xregister/rgxbckgrd.x +pkg/images/imcoords/ccmap.par +pkg/images/imcoords/doc/ccmap.hlp +pkg/images/imcoords/src/t_ccmap.x +pkg/images/imcoords/src/t_imcctran.x +pkg/images/lib/coomap.key +pkg/images/lib/geofit.gx +pkg/images/lib/geofit.x +pkg/images/lib/geograph.gx +pkg/images/lib/geograph.x +pkg/images/lib/geomap.h +pkg/images/lib/geomap.key +pkg/images/lib/rgtransform.x + Modifed the geomap, wcsmap, skymap, wregister, sregister, and ccmap + tasks to use the new cross terms option in the gsurfit library. + This involved changing two boolean parameters in each task to string + parameters, making the interactive fitting software shared by all + these tasks aware of the change, and modifying the gsinit calls + to do the initialization properly. + (5/1/97, Davis) + +pkg/images/immatch/src/t_geotran.x +pkg/images/immatch/src/geotran.x + Fixed various bugs triggered by the case where the user sets xmin, xmax, + ymin, or ymax, explicitly, and xmin > xmax or ymin > ymax. Improved + the precision of the flux conservation algorithm at the same time. + (4/30/97, Davis) + +pkg/images/imutil/src/imcopy.x + Changed imcopy so that it ignores the output image section if the + input and output root names are the same, making its behavior + consistent with other images package tasks which can overwrite the input + image. (4/24/97, Davis) + +pkg/images/immatch/doc/imcombine.hlp + Minor readability changes. (4/14/97, Valdes) + +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/images.cl b/pkg/images/images.cl new file mode 100644 index 00000000..342b3bea --- /dev/null +++ b/pkg/images/images.cl @@ -0,0 +1,38 @@ +#{ IMAGES package -- General image processing. + +# Check that login.cl version matches IRAF version. This has nothing to +# do with IMAGES, this is just a convenient place to test for an old +# login.cl, since IMAGES is virtually guaranteed to be loaded with IRAF. + +if (cl.logver != cl.version && cl.logregen) { + print ("WARNING: login.cl is outdated - rebuild with `mkiraf'") + beep; sleep(1); beep; sleep(1); beep +} + +set imcoords = "images$imcoords/" +set imfilter = "images$imfilter/" +set imfit = "images$imfit/" +set imgeom = "images$imgeom/" +set immatch = "images$immatch/" +set imutil = "images$imutil/" +set tv = "images$tv/" + +package images + +task imcoords.pkg = "imcoords$imcoords.cl" +task imfilter.pkg = "imfilter$imfilter.cl" +task imfit.pkg = "imfit$imfit.cl" +task imgeom.pkg = "imgeom$imgeom.cl" +task immatch.pkg = "immatch$immatch.cl" +task imutil.pkg = "imutil$imutil.cl" +task tv.pkg = "tv$tv.cl" + +# Load images subpackages (tv is not autoloaded). +imcoords +imfilter +imfit +imgeom +immatch +imutil + +clbye() diff --git a/pkg/images/images.hd b/pkg/images/images.hd new file mode 100644 index 00000000..d8521746 --- /dev/null +++ b/pkg/images/images.hd @@ -0,0 +1,46 @@ +# Help directory for the IMAGES package. + +$imcoords = "./imcoords/" +$imfilter = "./imfilter/" +$imfit = "./imfit/" +$imgeom = "./imgeom/" +$immatch = "./immatch/" +$imutil = "./imutil/" +$tv = "./tv/" + +revisions sys=Revisions + +imcoords men=imcoords$imcoords.men, + hlp=.., + src=imcoords$imcoords.cl, + pkg=imcoords$imcoords.hd + +imfilter men=imfilter$imfilter.men, + hlp=.., + src=imfilter$imfilter.cl, + pkg=imfilter$imfilter.hd + +imfit men=imfit$imfit.men, + hlp=.., + src=imfit$imfit.cl, + pkg=imfit$imfit.hd + +imgeom men=imgeom$imgeom.men, + hlp=.., + src=imgeom$imgeom.cl, + pkg=imgeom$imgeom.hd + +immatch men=immatch$immatch.men, + hlp=.., + src=immatch$immatch.cl, + pkg=immatch$immatch.hd + +imutil men=imutil$imutil.men, + hlp=.., + src=imutil$imutil.cl, + pkg=imutil$imutil.hd + +tv men=tv$tv.men, + hlp=.., + src=tv$tv.cl, + pkg=tv$tv.hd diff --git a/pkg/images/images.men b/pkg/images/images.men new file mode 100644 index 00000000..b9301a60 --- /dev/null +++ b/pkg/images/images.men @@ -0,0 +1,7 @@ + imcoords - Image coordinates package + imfilter - Image filtering package + imfit - Image fitting package + imgeom - Image geometric transformation package + immatch - Image matching and combining package + imutil - Image utilities package + tv - Image display utilities package diff --git a/pkg/images/images.par b/pkg/images/images.par new file mode 100644 index 00000000..73c03774 --- /dev/null +++ b/pkg/images/images.par @@ -0,0 +1,3 @@ +# Package parameters for IMAGES. + +version,s,h,"12Jan97" diff --git a/pkg/images/imcoords/Revisions b/pkg/images/imcoords/Revisions new file mode 100644 index 00000000..5c411d45 --- /dev/null +++ b/pkg/images/imcoords/Revisions @@ -0,0 +1,2026 @@ +.help revisions Jan97 images.imcoords +.nf + +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/imcoords/ccfind.par b/pkg/images/imcoords/ccfind.par new file mode 100644 index 00000000..bbc980f8 --- /dev/null +++ b/pkg/images/imcoords/ccfind.par @@ -0,0 +1,48 @@ +# Parameters for the CCFIND task + +# Input and output files and images +input,f,a,,,,The list input celestial coordinate files +output,f,a,"",,,The output matched coordinates files +images,f,a,"",,,The input images + +# The input coordinate file format +lngcolumn,i,h,1,,,Column containing the ra / longitude +latcolumn,i,h,2,,,Column containing the dec / latitude +lngunits,s,h,"",,,Input ra / longitude units +latunits,s,h,"",,,Input dec / latitude units +insystem,s,h,"j2000",,,Input celestial coordinate system + +# The celestial coordinate system reference point parameters +usewcs,b,h,no,,,Locate objects using the existing image wcs ? +xref,r,h,INDEF,,,The x reference pixel +yref,r,h,INDEF,,,The y reference pixel +xmag,r,h,INDEF,,,The x axis scale in arcsec / pixel +ymag,r,h,INDEF,,,The y axis scale in arcsec / pixel +xrotation,r,h,INDEF,,,The x rotation angle in degrees +yrotation,r,h,INDEF,,,The y axis rotation angle in degrees +lngref,s,h,"INDEF",,,Reference point ra / longitude coordinate +latref,s,h,"INDEF",,,Reference point dec / latitude coordinate +lngrefunits,s,h,"",,,Reference point ra / longitude units +latrefunits,s,h,"",,,Reference point dec / latitude units +refsystem,s,h,"j2000",,,Reference point coordinate system +projection,s,h,"tan",,,Sky projection geometry + +# Centeaing parameters. +center,b,h,yes,,,Center the pixel coordinates ? +sbox,i,h,21,11,,Search box width in pixels +cbox,i,h,9,5,,Centering box width in pixels +datamin,r,h,INDEF,,,Minimum good data value +datamax,r,h,INDEF,,,Maximum good data value +background,r,h,INDEF,,,Background reference value +maxiter,i,h,5,2,,Maximum number of iterations +tolerance,i,h,0,0,,Tolerance for convergence in pixels + +# Output parameters. +xformat,s,h,"",,,Output format for the x coordinate +yformat,s,h,"",,,Output format for the y coordinate + +# Task mode parameters. +verbose,b,h,yes,,,Print messages about progress of task ? + +mode,s,h,'ql' + diff --git a/pkg/images/imcoords/ccget.par b/pkg/images/imcoords/ccget.par new file mode 100644 index 00000000..50f00a55 --- /dev/null +++ b/pkg/images/imcoords/ccget.par @@ -0,0 +1,36 @@ +# Parameters for the CCGET task + +# Input and output files and images +input,f,a,,,,The input catalog file(s) +output,f,a,,,,The output catalog file(s) + +# The user field parameters. +lngcenter,s,a,"00:00:00.0",,,Ra / Longitude of field center +latcenter,s,a,"00:00:00",,,Dec / Latitude of field center +lngwidth,r,a,1.0,0.0,360.0,Ra / Longitude field width in degrees +latwidth,r,a,1.0,0.0,180.0,Dec / Latitude field width in degrees +fcsystem,s,h,"",,,The field center celestial coordinate system +fclngunits,s,h,"",,,Ra / Longitude units of field center +fclatunits,s,h,"",,,Dec / Latitude units of field center + +# The input catalog file parameters +colaliases,s,h,"",,,Input catalog column aliases +lngcolumn,s,h,"c2",,,Column containing the ra / longitude +latcolumn,s,h,"c3",,,Column containing the dec / latitude +catsystem,s,h,"j2000",,,Catalog celestial coordinate system +catlngunits,s,h,"",,,Catalog ra / longitude units +catlatunits,s,h,"",,, Catalog dec / latitude units + +# The output catalog file parameters +outsystem,s,h,"",,,Output celestial coordinate system +olngunits,s,h,"",,,Output ra / longitude units +olatunits,s,h,"",,, Ouput dec / latitude units +olngformat,s,h,"",,,Output ra / longitude format +olatformat,s,h,"",,, Ouput dec / latitude format +exprs,s,h,"c[*]",,,The list of output column expressions +formats,s,h,"",,,The optional output formats string + +# Output and graphics mode parameters +verbose,b,h,yes,,,Print messages about progress of task ? + +mode,s,h,'ql' diff --git a/pkg/images/imcoords/ccmap.par b/pkg/images/imcoords/ccmap.par new file mode 100644 index 00000000..bba6a4c2 --- /dev/null +++ b/pkg/images/imcoords/ccmap.par @@ -0,0 +1,54 @@ +# Parameters for the CCMAP task + +# Input and output files and images +input,f,a,,,,The input coordinate files +database,f,a,,,,The output database file +solutions,s,h,"",,,The database plate solution names +images,f,h,"",,,The input images +results,f,h,"",,,The optional results summary files + +# The input coordinate file format +xcolumn,i,h,1,,,Column containing the x coordinate +ycolumn,i,h,2,,,Column containing the y coordinate +lngcolumn,i,h,3,,,Column containing the ra / longitude +latcolumn,i,h,4,,,Column containing the dec / latitude +xmin,r,h,INDEF,,,Minimum logical x pixel value +xmax,r,h,INDEF,,,Maximum logical x pixel value +ymin,r,h,INDEF,,,Minimum logical y pixel value +ymax,r,h,INDEF,,,Maximum logical y pixel value +lngunits,s,h,"",,,Input ra / longitude units +latunits,s,h,"",,,Input dec / latitude units +insystem,s,h,"j2000",,,Input celestial coordinate system + +# The celestial coordinate system reference point parameters +refpoint,s,h,"coords","|coords|user|tweak|",,Source of the reference point definition +xref,s,h,"INDEF",,,Reference point in x +yref,s,h,"INDEF",,,Reference point in y +lngref,s,h,"INDEF",,,Reference point ra / longitude telescope coordinate +latref,s,h,"INDEF",,,Reference point dec / latitude telescope coordinate +refsystem,s,h,"INDEF",,,Reference point telescope coordinate system +lngrefunits,s,h,"",,,Reference point ra / longitude units +latrefunits,s,h,"",,,Reference point dec / latitude units + +# Coordinate map fitting parameters +projection,s,h,"tan",,,Sky projection geometry +fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general|,,Fitting geometry +function,s,h,"polynomial",|chebyshev|legendre|polynomial|,,Surface type +xxorder,i,h,2,2,,Order of xi fit in x +xyorder,i,h,2,2,,Order of xi fit in y +xxterms,s,h,"half","|none|half|full|",,Xi fit cross terms type +yxorder,i,h,2,2,,Order of eta fit in x +yyorder,i,h,2,2,,Order of eta fit in y +yxterms,s,h,"half","|none|half|full|",,Eta fit cross terms type +maxiter,i,h,0,,,The maximum number of rejection iterations +reject,r,h,3.0,,,Rejection limit in sigma units + +# Output and graphics mode parameters +update,b,h,no,,,Update the image world coordinate system ? +pixsystem,s,h,"logical",|logical|physical|",,Input pixel coordinate system +verbose,b,h,yes,,,Print messages about progress of task ? +interactive,b,h,yes,,,Fit the transformation interactively ? +graphics,s,h,"stdgraph",,,Default graphics device +cursor,*gcur,h,,,,Graphics cursor + +mode,s,h,'ql' diff --git a/pkg/images/imcoords/ccsetwcs.par b/pkg/images/imcoords/ccsetwcs.par new file mode 100644 index 00000000..45afbf7a --- /dev/null +++ b/pkg/images/imcoords/ccsetwcs.par @@ -0,0 +1,28 @@ +# Parameters for the COOWCS task + +# Input and output files and images +images,f,a,,,,The input images +database,f,a,,,,The input database file +solutions,f,a,"",,,The input plate solutions + +# The celestial coordinate system parameters +xref,r,h,INDEF,,,The x reference pixel +yref,r,h,INDEF,,,The y reference pixel +xmag,r,h,INDEF,,,The x axis scale in arcsec / pixel +ymag,r,h,INDEF,,,The y axis scale in arcsec / pixel +xrotation,r,h,INDEF,,,The x axis rotation angle in degrees +yrotation,r,h,INDEF,,,The y axis rotation angle in degrees +lngref,r,h,INDEF,,,The ra / longitude reference coordinate in lngunits +latref,r,h,INDEF,,,The dec / latitude reference coordinate in latunits +lngunits,s,h,"",,,The ra / longitude reference coordinate units +latunits,s,h,"",,,The dec / latitude reference coordinate units +transpose,b,h,no,,,Transpose the computed image wcs ? +projection,s,h,"tan",,,The sky projection geometry +coosystem,s,h,"j2000",,,The celestial coordinate system + +# Output and graphics mode parameters +update,b,h,yes,,,Update the image world coordinate system ? +pixsystem,s,h,"logical","|logical|physical|",,The input pixel coordinate system +verbose,b,h,yes,,,Print messages about actions taken by the task ? + +mode,s,h,'ql' diff --git a/pkg/images/imcoords/ccstd.par b/pkg/images/imcoords/ccstd.par new file mode 100644 index 00000000..13dc92b3 --- /dev/null +++ b/pkg/images/imcoords/ccstd.par @@ -0,0 +1,31 @@ +# Parameter set for the CCSTD Task + +input,s,a,,,,The input coordinate files +output,s,a,,,,The output coordinate files +database,s,a,,,,The input database file +solutions,s,a,,,,The plate solutions +geometry,s,h,"linear","|linear|geometric|",,"The solution type (linear,geometric)" +forward,b,h,yes,,,Transform to standard coordinates ? +polar,b,h,no,,,Work in polar standard coordinates ? +xref,r,h,INDEF,,,The X reference coordinate +yref,r,h,INDEF,,,The Y reference coordinate +xmag,r,h,INDEF,,,The X axis scale in arcsec per X reference coordinate +ymag,r,h,INDEF,,,The Y axis scale in arcsec per Y reference coordinate +xrotation,r,h,INDEF,,,The X axis rotation angle in degrees +yrotation,r,h,INDEF,,,The Y axis rotation angle in degrees +lngref,r,h,INDEF,,,The ra / longitude reference coordinate in lngunits +latref,r,h,INDEF,,,The dec / latitude reference coordinate in latunits +lngunits,s,h,"",,,The ra / longitude coordinate units +latunits,s,h,"",,,The dec / latitude coordinate units +projection,s,h,"tan","",,The sky projection geometry +xcolumn,i,h,1,1,100,Input column containing the x / standard coordinate +ycolumn,i,h,2,1,100,Input column containing the y / standard coordinate +lngcolumn,i,h,3,1,100,Input column containing the longitude / standard coordinate +latcolumn,i,h,4,1,100,Input column containing the latitude / standard coordinate +lngformat,s,h,"",,,Output format of the standard / longitude coordinate +latformat,s,h,"",,,Output format of the standard / latitude coordinate +xformat,s,h,"",,,Output format of the standard / x coordinate +yformat,s,h,"",,,Output format of the standard / y coordinate +min_sigdigits,i,h,7,,,Minimum precision of the output coordinates +mode,s,h,'ql' + diff --git a/pkg/images/imcoords/cctran.par b/pkg/images/imcoords/cctran.par new file mode 100644 index 00000000..a9c51d48 --- /dev/null +++ b/pkg/images/imcoords/cctran.par @@ -0,0 +1,28 @@ +# Parameter set for the CCTRAN Task + +input,s,a,,,,The input coordinate files +output,s,a,,,,The output coordinate files +database,f,a,,,,The input database file +solutions,s,a,,,,The input plate solutions +geometry,s,h,"geometric","|linear|geometric|",,"Transformation type (linear,geometric)" +forward,b,h,yes,,,Transform x / y to ra / dec (yes) or vice versa (no) ? + +xref,r,h,INDEF,,,The X reference pixel +yref,r,h,INDEF,,,The Y reference pixel +xmag,r,h,INDEF,,,The X axis scale in arcsec per pixel +ymag,r,h,INDEF,,,The Y axis scale in arcsec per pixel +xrotation,r,h,INDEF,,,The X axis rotation angle in degrees +yrotation,r,h,INDEF,,,The Y axis rotation angle in degrees +lngref,r,h,INDEF,,,The ra / longitude reference coordinate in lngunits +latref,r,h,INDEF,,,The dec / latitude reference coordinate in latunits +lngunits,s,h,"",,,The input / output ra / longitude reference coordinate units +latunits,s,h,"",,,The input / output dec / latitude reference coordinate units +projection,s,h,"tan",,,The sky projection geometry + +xcolumn,i,h,1,1,100,Input column containing the x / ra / longitude coordinate +ycolumn,i,h,2,1,100,Input column containing the y / dec / latitude coordinate +lngformat,s,h,"",,,Output format of the ra / longitude / x coordinate +latformat,s,h,"",,,Output format of the dec / latitude / y coordinate +min_sigdigits,i,h,7,,,Minimum precision of the output coordinates + +mode,s,h,'ql' diff --git a/pkg/images/imcoords/ccxymatch.par b/pkg/images/imcoords/ccxymatch.par new file mode 100644 index 00000000..a5fe93ee --- /dev/null +++ b/pkg/images/imcoords/ccxymatch.par @@ -0,0 +1,41 @@ +# Parameter file for CCXYMATCH + +input,f,a,,,,The input pixel coordinate lists +reference,f,a,,,,The input celestial coordinate lists +output,f,a,,,,The output matched coordinate lists +tolerance,r,a,1,,,The matching tolerance in arcseconds +ptolerance,r,a,3,,,The matching tolerance in pixels + +refpoints,f,h,"",,,The optional list of reference points +xin,r,h,INDEF,,,The X coordinate of the reference point +yin,r,h,INDEF,,,The Y coordinate of the reference point +xmag,r,h,INDEF,,,The X axis scale in arcseconds / pixel +ymag,r,h,INDEF,,,The Y axis scale in arcseconds / pixel +xrotation,r,h,INDEF,,,The X axis rotation in degrees +yrotation,r,h,INDEF,,,The Y axis rotation in degrees +projection,s,h,"tan",,,The sky projection geometry +lngref,r,h,INDEF,,,The ra / longitude of the reference point +latref,r,h,INDEF,,,The dec / latitude of the reference point + +lngcolumn,i,h,1,1,,The reference list ra / longitude coordinate column +latcolumn,i,h,2,1,,The reference list dec / latitude coordinate column +xcolumn,i,h,1,1,,The pixel list x coordinate column +ycolumn,i,h,2,1,,The pixel list y coordinate column +lngunits,s,h,"hours","|degrees|radians|hours|",,The ra / longitude units +latunits,s,h,"degrees","|degrees|radians|",,The dec / latitude units + +separation,r,h,3.0,,,The minimum object separation in arcseconds +pseparation,r,h,9.0,,,The minimum object separation in pixels +matching,s,h,"triangles","|tolerance|triangles|",,The matching algorithm +nmatch,i,h,30,,,The maximum number of points for triangles algorithm +ratio,r,h,10.0,5.0,10.0,The maximum ratio of longest to shortest side of triangle +nreject,i,h,10,,,The maximum number of rejection iterations + +lngformat,s,h,"",,,The format of the output ra / longitude coordinate +latformat,s,h,"",,,The format of the output dec / latitude coordinate +xformat,s,h,"%13.3f",,,The format of the output x coordinate +yformat,s,h,"%13.3f",,,The format of the output y coordinate + +verbose,b,h,yes,,,Verbose mode ? + +mode,s,h,ql,,, diff --git a/pkg/images/imcoords/doc/ccfind.hlp b/pkg/images/imcoords/doc/ccfind.hlp new file mode 100644 index 00000000..33eceb7c --- /dev/null +++ b/pkg/images/imcoords/doc/ccfind.hlp @@ -0,0 +1,596 @@ +.help ccfind Jun99 images.imcoords +.ih +NAME +ccfind -- locate objects in an image given a celestial coordinate list and +the image wcs +.ih +USAGE +ccfind input output image +.ih +PARAMETERS +.ls input +The list of input celestial coordinate files. Coordinates may be entered +by hand by setting input to "STDIN". A STDIN coordinate list is terminated +by typing (usually or ). +.le +.ls output +The list of output matched coordinate files. The computed pixel values +are appended to the input coordinate file line and written to output. The number +of output files must equal the number of input files. Results may be +printed on the terminal by setting output to "STDOUT". +.le +.ls image +The list of input images associated with the input coordinate files. The number +of input images must equal the number of input coordinate files. +.le +.ls lngcolumn = 1, latcolumn = 2 +The input coordinate file columns containing the celestial ra / longitude and +dec / latitude coordinates respectively. +.le +.ls lngunits = "", latunits = "" +The units of the input ra / longitude and dec / latitude coordinates. The +options are "hours", "degreees", and "radians" for ra / longitude and +"degrees" and "radians" for dec / latitude. If lngunits and latunits are +undefined they default to the preferred units for the coordinates +system specified by \fIinsystem\fR, e.g. "hours" and "degrees" for +equatorial systems and "degrees" and "degrees" for ecliptic, galactic, and +supergalactic systems. +.le +.ls insystem = "j2000" +The input celestial coordinate system. The \fIinsystem\fR parameter +sets the preferred units for the input celestial coordinates, and +tells CCFIND how to transform the input celestial coordinates +the input image celestial coordinate system. The systems of most +interest to users are "icrs", "j2000", and "b1950". The full set +of options are the following: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System (ICRS) where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for the icrs, fk5, galactic, and supergalactic +coordinate systems is only used if the input coordinates are in the +equatorial fk4, noefk4, fk5, or icrs systems and proper motions are supplied. +Since CCFIND does not currently support proper motions these fields are +not required. +.le +.ls usewcs = no +Use image header information to compute the input image celestial coordinate +system ? If usewcs is "yes", the image coordinate system is read from the +image header. If usewcs is "no", the input image celestial coordinates +system is defined by \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, +\fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +\fIlngrefunits\fR, \fIlatrefunits\fR, \fIrefsystem\fR, and \fIprojection\fR +parameters respectively. +.le +.ls xref = INDEF, yref = INDEF +The x and y pixel coordinates of the reference point. +xref and yref default to the center of the image in pixel coordinates. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in arcseconds per pixel. xmag and ymag default +to 1.0 and 1.0 arcseconds per pixel. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles in degrees. xrotation and yrotation are +interpreted as the rotation of the ra / longitude and dec / latitude +coordinates with respect to the x and y axes, and default 0.0 and 0.0 degrees +respectively. To set east to the up, down, left, and right directions, +set xrotation to 90, 270, 180, and 0 respectively. To set north to the +up, down, left, and right directions, set yrotation to 0, 180, 90, and 270 +degrees respectively. Any global rotation must be added to both the +xrotation and yrotation values. +.le +.ls lngref = "INDEF", latref = "INDEF" +The ra / longitude and dec / latitude of the reference point. Lngref and latref +may be numbers, e.g 13:20:42.3 and -33:41:26, or keywords for the +appropriate parameters in the image header, e.g. RA and DEC for NOAO +image data. If lngref and latref are undefined they default to 0.0 and 0.0 +respectively. +.le +.ls lngrefunits = "", latrefunits = "" +The units of the reference point celestial coordinates. The options +are "hours", "degrees", and "radians" for the ra / longitude coordinates, +and "degrees" and "radians" for the dec /latitude coordinates. +If lngrefunits and latrefunits are undefined they default to the preferred +units of the reference system. +.le +.ls refsystem = "INDEF" +The celestial coordinate system of the reference point. Refsystem may +be any one of the options listed under the \fIinsystem\fR parameter, e.g. +"b1950", or an image header keyword containing the epoch of the observation +in years, e.g. EPOCH for NOAO data. If refsystem is undefined +the celestial coordinate system of the reference point defaults to the +celestial coordinate system of the input coordinates \fIinsystem\fR. +.le +.ls projection = "tan" +The sky projection geometry. The most commonly used projections in +astronomy are "tan", "arc", "sin", and "lin". Other supported projections +are "ait", "car", "csc", "gls", "mer", "mol", "par", "pco", "qsc", "stg", +"tsc", and "zea". +.le +.ls center = yes +Center the object pixel coordinates using an x and y marginal centroiding +algorithm ? +.le +.ls sbox = 21 +The search box width in pixels. Sbox defines the region of the input image +searched and used to compute the initial x and y marginal centroids. Users +worried about contamination can set sbox = cbox, so that the first +centering iteration will be the same as the others. +.le +.ls cbox = 9 +The centering box width in pixels. Cbox defines the region of the input +image used to compute the final x and y marginal centroids. +.le +.ls datamin = INDEF, datamax = INDEF +The minimum and maximum good data values. Values outside this range +are exclude from the x and y marginal centroid computation. +.le +.ls background = INDEF +The background value used by the centroiding algorithm. If background is +INDEF, a value equal to the mean value of the good data pixels for +each object is used. +.le +.ls maxiter = 5 +The maximum number of centroiding iterations to perform. The centroiding +algorithm will halt when this limit is reached or when the desired tolerance +is reached. +.le +.ls tolerance = 0 +The convergence tolerance of the centroiding algorithm. Tolerance is +defined as the maximum permitted integer shift of the centering box in +pixels from one iteration to the next. +.le +.ls verbose +Print messages about actions taken by the task? +.le + +.ih +DESCRIPTION + +CCFIND locates the objects in the input celestial coordinate lists \fIinput\fR +in the input images \fIimage\fR using the image world coordinate system, +and writes the located objects to the output matched coordinates files +\fIoutput\fR. CCFIND computes the pixel coordinates of each object by, +1) transforming the input celestial coordinates to image celestial coordinate +system, 2) using the image celestial coordinate system to compute the +initial pixel coordinates, and 3) computing the final pixel coordinates +using a centroiding algorithm. The image celestial coordinate system may +be read from the image header or supplied by the user. The CCFIND output +files are suitable for input to the plate solution computation task CCMAP. + +The input ra / longitude and dec / latitude coordinates are read from +columns \fIlngcolumn\fR and \fIlatcolumn\fR in the input coordinate +file respectively. + +The input celestial coordinate system is set by the \fIinsystem\fR parameter, +and must be one of the following: equatorial, ecliptic, galactic, or +supergalactic. The equatorial coordinate systems must be one of: 1) FK4, +the mean place pre-IAU 1976 system, 2) FK4-NO-E, the same as FK4 but without +the E-terms, 3) FK5, the mean place post-IAU 1976 system, 4) ICRS the +International Celestial Reference System, 5) GAPPT, the geocentric apparent +place in the post-IAU 1976 system. + +The \fIlngunits\fR and \fIlatunits\fR parameters set the units of the input +celestial coordinates. If undefined, lngunits and latunits assume sensible +defaults for the input celestial coordinate system set by the \fIinsystem\fR +parameter, e.g. "hours" and "degrees" for equatorial coordinates and "degrees" +and "degrees" for galactic coordinates. + +If the \fIusewcs\fR parameter is "yes", the image celestial coordinate +system is read from the image header keywords CRPIX, CRVAL, CD or CDELT/CROTA, +RADECSYS, EQUINOX or EPOCH, and MJD-OBS or DATE-OBS, where the mathematical +part of this transformation is shown below. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = CD1_1 + c = CD1_2 + e = CD2_1 + f = CD2_2 + a = - b * CRPIX1 - c * CRPIX2 + d = - e * CRPIX1 - f * CRPIX2 + lng = CRVAL1 + PROJ (xi, eta) + lat = CRVAL2 + PROJ (xi, eta) +.fi + +If usewcs is "no", then the image celestial coordinate system is computed +using the values of the \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, +\fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +\fIlngrefunits\fR, \fIlatrefunits\fR, \fIrefsystem\fR, and \fIprojection\fR +supplied by the user, where the mathematical part of this transformation is +shown below. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = - b * xref - c * yref + d = - e * xref - f * yref + lng = lngref + PROJ (xi, eta) + lat = latref + PROJ (xi, eta) +.fi + +In both the above examples, x and y are the pixel coordinates, xi and eta +are the usual projected (standard) coordinates, lng and lat are the celestial +coordinates, and PROJ stands for the projection function, usually +the tangent plane projection function. + +Once the image celestial coordinate system is determined, CCFIND transforms +the input celestial coordinates to the image celestial coordinate system +using the value of the \fIinsystem\fR parameter, and either the values of +the image header keywords RADECSYS, EQUINOX / EPOCH, and MJD-OBS / DATE-OBS +(if \fIusewcs\fR = "yes"), or the value of the \fIrefsystem\fR parameter (if +\fIusewcs\fR = "no"), and then transforms the image celestial coordinates +to pixel coordinates using the inverse of the transformation functions +shown above. + +If \fIcenter\fR is yes, CCFIND locates the objects in the input +image using an xn and y marginal centroiding algorithm. Pixels +inside a box \fIsbox\fR pixels wide centered in the initial coordinates, +are used to locate the objects in the image. Accurate final centering +is done using pixels inside a region \fIcbox\fR pixels wide centered on +these initial coordinates. Sbox should be set to a value large enough +to locate the object, but small enough to exclude other bright sources. +Cbox should be set to a value small enough to exclude sky values and other +bright sources, but large enough to include the wings of point sources. +Bad data can be excluded from the centroiding algorithm by setting +the \fIdatamin\fR and \fIdatamax\fR parameters. If \fIbackground\fR is +undefined then the centroiding algorithm sets the background value to +the mean of the good data values inside the centering box. +The centroiding algorithm iterates until the maximum number of +iterations \fImaxiter\fR limit is reached, or until the tolerance +criteria \fItolerance\fR is achieved. + +Only objects whose coordinates are successfully located in the +input image are written to the output coordinate file. The computed +output pixel coordinates are appended to the input image line using +the format parameters \fIxformat\fR and \fIyformat\fR parameters, +whose default values are "%10.3f" and "%10.3f" respectively + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +cctran.hlp-(67%)-line 268-file 1 of 1 +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +EXAMPLES + +1. Locate the object in the list wpix.coords in the image wpix using +the existing image header wcs. The input celestial coordinates file +contains j2000 GSC catalog coordinates of 5 objects in the field. +The image wcs is in b1950. + +.nf +cl> imcopy dev$wpix wpix + ... copy the test image into the current directory + +cl> hedit wpix equinox 1950.0 add+ + ... change the epoch keyword value to the correct number + +cl> type wpix.coords +13:29:47.297 47:13:37.52 +13:29:37.406 47:09:09.18 +13:29:38.700 47:13:36.23 +13:29:55.424 47:10:05.15 +13:30:01.816 47:12:58.79 + +cl> ccfind wpix.coords wpix.match wpix usewcs+ + +Input File: wpix.coords Output File: wpix.match + Image: wpix Wcs: +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Refsystem: wpix.imh logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK4 Equinox: B1950.000 + Epoch: B1987.25767884 MJD: 46890.00000 +Located 5 objects in image wpix + +cl> type wpix.match +# Input File: wpix.coords Output File: wpix.match +# Image: wpix Wcs: +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Refsystem: wpix.imh logical Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK4 Equinox: B1950.000 +# Epoch: B1987.25767884 MJD: 46890.00000 + +13:29:47.297 47:13:37.52 327.504 410.379 +13:29:37.406 47:09:09.18 465.503 62.101 +13:29:38.700 47:13:36.23 442.013 409.654 +13:29:55.424 47:10:05.15 224.351 131.200 +13:30:01.816 47:12:58.79 134.373 356.327 + +cl> ccmap wpix.match ccmap.db xcol=3 ycol=4 lngcol=1 latcol=2 ... +.fi + +2. Repeat the previous example but input the image coordinate system by hand. +The scale is known to be ~0.77 arcseconds per pixel, north is up, east is left, +and the center of the image is near ra = 13:27:47, dec = 47:27:14 in 1950 +coordinates. + +.nf +cl> ccfind wpix.coords wpix.match wpix xmag=-0.77 ymag=.77 lngref=13:27:47 \ +latref=47:27:14 refsystem=b1950. + +Input File: wpix.coords Output File: wpix.match.1 + Image: wpix Wcs: +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Refsystem: b1950 Coordinates: equatorial FK4 + Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 +Located 5 objects in image wpix + + +cl> type wpix.match + +# Input File: wpix.coords Output File: wpix.match +# Image: wpix Wcs: +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Refsystem: b1950 Coordinates: equatorial FK4 +# Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 + +13:29:47.297 47:13:37.52 327.504 410.379 +13:29:37.406 47:09:09.18 465.503 62.101 +13:29:38.700 47:13:36.23 442.013 409.654 +13:29:55.424 47:10:05.15 224.351 131.200 +13:30:01.816 47:12:58.79 134.373 356.327 +.fi + +3. Repeat the previous example but read the ra, dec, and epoch from the +image header keywords RA, DEC, and EPOCH. It turns out the telescope +RA and DEC recorded in the image header are not very accurate and that +EPOCH is 0.0 instead of 1987.26 so we will fix up the header before +trying out the example. + +.nf +cl> hedit wpix EPOCH 1987.26 +cl> hedit wpix RA '13:29:21' +cl> hedit wpix DEC '47:15:42' + +cl> ccfind wpix.coords wpix.match wpix xmag=-0.77 ymag=.77 lngref=RA \ +latref=DEC refsystem=EPOCH + +Input File: wpix.coords Output File: wpix.match + Image: wpix Wcs: +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Refsystem: 1987.26 Coordinates: equatorial FK5 + Equinox: J1987.260 Epoch: J1987.26000000 MJD: 46891.21500 +Located 5 objects in image wpix + +# Input File: wpix.coords Output File: wpix.match +# Image: wpix Wcs: +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Refsystem: 1987.26 Coordinates: equatorial FK5 +# Equinox: J1987.260 Epoch: J1987.26000000 MJD: 46891.21500 + +13:29:47.297 47:13:37.52 327.504 410.379 +13:29:37.406 47:09:09.18 465.503 62.101 +13:29:38.700 47:13:36.23 442.013 409.654 +13:29:55.424 47:10:05.15 224.351 131.200 +13:30:01.816 47:12:58.79 134.373 356.327 +.fi + +4. Use ccfind to predict the pixel coordinate in the last example by +turning off the object centering, and mark the predicted coordinates +on the image display with red dots. + +.nf +cl> ccfind wpix.coords wpix.match wpix xmag=-0.77 ymag=.77 lngref=RA \ +latref=DEC refsystem=EPOCH center- + +Input File: wpix.coords Output File: wpix.match + Image: wpix Wcs: +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Refsystem: 1987.26 Coordinates: equatorial FK5 + Equinox: J1987.260 Epoch: J1987.26000000 MJD: 46891.21500 +Located 5 objects in image wpix + +cl> type wpix.match + +# Input File: wpix.coords Output File: wpix.match +# Image: wpix Wcs: +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Refsystem: 1987.26 Coordinates: equatorial FK5 +# Equinox: J1987.260 Epoch: J1987.26000000 MJD: 46891.21500 + +13:29:47.297 47:13:37.52 333.954 401.502 +13:29:37.406 47:09:09.18 465.338 53.175 +13:29:38.700 47:13:36.23 447.687 399.967 +13:29:55.424 47:10:05.15 226.600 125.612 +13:30:01.816 47:12:58.79 141.892 351.084 + +cl> display wpix 1 + +cl> fields wpix.match 3,4 | tvmark 1 STDIN col=204 + +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +starfind, ccxymatch, ccmap, ccsetwcs, cctran +.endhelp diff --git a/pkg/images/imcoords/doc/ccget.hlp b/pkg/images/imcoords/doc/ccget.hlp new file mode 100644 index 00000000..fef9afba --- /dev/null +++ b/pkg/images/imcoords/doc/ccget.hlp @@ -0,0 +1,463 @@ +.help ccget Oct00 images.imcoords +.ih +NAME +ccget -- extract objects in a user specified field from a text file catalog +.ih +USAGE +ccget input output lngcenter latcenter lngwidth latwidth +.ih +PARAMETERS +.ls input +The input text file catalog(s). The text file columns must be +delimited by whitespace and all the input catalogs must have the same format. +.le +.ls output +The output catalogs containing the extracted objects. The number of +output catalogs must be one or equal to the number of input catalogs. +.le +.ls lngcenter, latcenter +The center of the field containing the objects to be extracted. Lngcenter and +latcenter are assumed to be in the coordinate system specified by +\fIfcsystem\fR, e.g. ra and dec for equatorial systems, galactic longitude and +latitude for galactic systems, etc. and in the units specified by +\fIfclngunits\fR and \fIlatunits\fR. +.le +.ls lngwidth, latwidth +The width of the user specified field in degrees. +.le +.ls fcsystem = "" +The celestial coordinate system of the field center. If undefined fcsystem +defaults to the catalog celestial coordinate system specified by +\fIcatsystem\fR. The two systems of +most interest to users are "j2000" and "b1950". The full set of options is: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for the fk5, galactic, and supergalactic +coordinate systems is only used if the input coordinates are in the +equatorial fk4, noefk4, or fk5 systems and proper motions are supplied. +Since ccget does not currently support proper motions these fields are +not required. +.le + +.ls fclngunits = "", fclatunits = "" +The units of the field center coordinates. The options are "hours", "degrees", +and "radians" for the ra / longitude coordinate and "degrees" and "radians" +for the dec / latitude coordinates. If fclngunits and fclatunits are undefined +they default to the preferred units for the given system, e.g. "hours" and +degrees" for equatorial systems and "degrees" and "degrees" for ecliptic, +galactic, and supergalactic systems. +.le +.ls colaliases = "" +The list of input catalog column aliases separated by commas. By default the +catalog columns are "c1", "c2", "c10", etc. If colaliases is defined then +the aliases are assigned to the columns in order. For example if colaliases +is "id,ra,dec,v,bv" then columns c1, c2, c3, c4, c5 will be assigned +the names id, ra, dec, v, and bv and any remaining columns in the input catalog +file will be assigned default names beginning with c6. +.le +.ls lngcolumn = "c2", latcolumn = "c3" +The input catalog columns containing the coordinates of catalog objects. +.le +.ls catsystem = "j2000" +The celestial coordinate system of the input catalog(s). The two systems of +most interest to users are "j2000" and "b1950". The full set of options is +described in the \fIfcsystem\fR parameter section. +.le +.ls catlngunits = "", catlatunits = "" +The units of the catalog coordinates. The options are "hours", "degrees", +and "radians" for the ra / longitude coordinate and "degrees" and "radians" +for the dec / latitude coordinates. If catlngunits and catlatunits are undefined +they default to the preferred units for the catalog system, e.g. "hours" and +degrees" for equatorial systems and "degrees" and "degrees" for ecliptic, +galactic, and supergalactic systems. +.le +.ls outsystem = "" +The celestial coordinate system of the output coordinates. If undefined +outsystem defaults to the celestial coordinate system of the catalog. +The two systems of most interest to users are "j2000" and "b1950". The +full set of options is described under the \fIfcsystem\fR parameter +section. +.le +.ls olngunits = "", olatunits = "" +The units of the output coordinates. The options are "hours", "degrees", +and "radians" for the ra / longitude coordinate and "degrees" and "radians" +for the dec / latitude coordinates. If olngunits and olatunits are undefined +they default to the preferred units for outsystem, e.g. "hours" and degrees" for +equatorial systems and "degrees" and "degrees" for ecliptic, galactic, and +supergalactic systems. +.le +.ls olngformat = "", olatformat="" +The output ra / longitude and dec / latitude formats if the output +celestial coordinate system is different from the catalog celestial +coordinate system. The defaults are " %010.1h" for hours, " %9h" for degrees +and " %9.7g" for radians. +.le +.ls exprs = "c[*]" +The list of output columns and column expressions separated by commas. +By default the entire record for the extracted object is output exactly +as it is. The output columns can be individual columns e.g. c1 or c5 +or column ranges, e.g. c[1-10] or c[2-4]. Column expressions are +expressions of the catalog columns, e.g c4 + c5. Columns and column +expression are output in the order in which they appear in exprs. +.le +.ls formats = "" +An optional list of column formats separated by commas. Column formats must +be placeholders, e.g. the letter f for existing columns which are not +reformatted (with the possible exception of the coordinate columns). +Column expression formats may be any regular formatting expression. +For example if \fIexprs\fR is "c[1-3],c4+c5,c5+c7", then formats might be +"f,%7.3f,%7.3f". +.le +.ls verbose = yes +Print messages on the standard output about actions taken by the task. +.le + +.ih +DESCRIPTION + +Ccget extracts objects in a user specified field from the input catalogs +\fIinput\fR and writes the extracted records to the output +catalogs \fIoutput\fR. + +The user field is specified by the parameters \fIlngcenter\fR, \fIlatcenter\fR, +\fIlngwidth\fR, and \fIlatwidth\fR, where the field center is entered in +the celestial coordinate system specified by \fIfcsystem\fR and the +units are specified by \fIfclngunits\fR and \fIfclatunits\fR. If fcsystem +is undefined it defaults to the value of the catalog coordinate system +\fIcatsystem\fR. + +The input catalogs must be text files containing 2 or more columns separated +by whitespace. By default these columns are assigned names of the form +c1, c2, ..., cn. Legal columns names must have the form described +in the following column names section. Users may assign their own names +to the columns by setting +the \fIcolaliases\fR parameter. The input catalog columns \fIlngcolumn\fR and +\fIlatcolumn\fR must contain the ra / longitude and dec / latitude coordinates +of the catalog objects respectively. The parameters \fIcatsystem\fR, +\fIcatlngunits\fR, and \fIcatlatunits\fR specify the coordinate system +of the input catalog and its coordinate units respectively. + +At task startup the user field center is transformed from the coordinate +system defined by \fIfcsystem\fR to the catalog coordinate system +\fIcatsystem\fR and the ra / longitude and dec / latitude limits of the +user field are computed. As each input catalog record is read, the catalog +coordinates are decoded and tested against these limits. If the +object is inside the user field then the column and column +expressions specified by \fIexprs\fR are extracted from the input catalogs +and written to the output catalogs. + +If the output celestial coordinate system \fIoutsystem\fR is +different from \fIcatsystem\fR, then the catalog coordinates are transformed +and to the output coordinates system, and written to the output catalog +in the units specified +by \fIolngunits\fR and \fIolatunits\fR, with the formats specified by +\fIolngformat\fR and \fIolatformat\fR. Existing columns are written to +the output catalog in the same +format they have in the input catalog. Column expressions are written +using the formats specified by \fIformats\fR or the builtin defaults +of %5b, %10d, %10g, or %s for boolean, integer, floating point, or +string columns respectively. + +.ih +COLUMN NAMES + +By default column names are of the form c1, c2, ..., cN. However users can +also define their own column names, which must have the following syntax + +.nf + {a-zA-Z}[{a-zA-Z0-9._$}]* +.fi + +where [] indicates optional, {} indicates a class, - indicates an ascii +range of characters, and * indicates zero or more occurrences. In words +a column name must begin with an alphabetic character and be followed +by any combination of alphabetic, digit, or '.', '_', and '$' characters. +The ccget task imposes a 19 character limit on the columns names so it is +best to keep them short. + +.ih +COLUMN EXPRESSIONS + +Expressions must consist of operands and operators. The operands may be +column names, numeric constants, functions, and quoted string constants. +Values given as sexagesimal strings are automatically converted to +decimal numbers. The operators are arithmetic, logical, and string. + +The following operators are supported: + + +.nf + + - * / arithmetic operators + ** exponentiation + // string concatenation + ! - boolean not, unary negation + < <= > >= order comparison (works for strings) + == != && || equals, not equals, and, or + ?= string equals pattern + ? : conditional expression +.fi + +The following intrinsic functions are supported: + + +.nf + abs atan2 deg log min real sqrt + acos bool double log10 mod short str + asin cos exp long nint sin tan + atan cosh int max rad sinh tanh +.fi + + +.ih +COLUMN FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +SOME BUILTIN CATALOG FORMATS + +The nlandolt.dat catalog in noao$photcal/catalogs/ has the following format. + +.nf +# Column Quantity + + 1 id + 2 ra + 3 dec + 4 v + 5 b-v + 6 u-b + 7 v-r + 8 r-i + 9 v-i + 10 n + 11 m + 12 err(v) + 13 err(b-v) + 14 err(u-b) + 15 err(v-r) + 16 err(r-i) + 17 err(v-i) +.fi + +where the coordinates are in j2000, the errors are all mean errors of the mean, +and n and m are the number of observations and number of independent nights +of observations respectively. + +.ih +REFERENCES + +The catalog references are + +.nf +nlandolt.dat - Landolt, A.U. 1992, A.J. 104, 340 +.fi + +.ih +EXAMPLES + +Example 1. Extract all Landolt standard stars within a 1 degree field +surrounding the position ra = 3:55:00 dec = 0:00:00 (J2000). + +.nf +cl> ccget nlandolt.dat output 03:55:00.0 0:00:00 1.0 1.0 +.fi + +Example 2. Repeat example 1 but output the coordinates in the b1950 +celestial coordinate system. + +.nf +cl> ccget nlandolt.dat output 03:55:00.0 0:00:00 1.0 1.0 \ +outsystem=b1950 +.fi + +Example 3. Repeat example 1 but extract only the id, ra, dec, v, +and b-v fields from the Landolt catalog. Note that since these +columns are the first five in the catalog they can be specified +as a range. + +.nf +cl> ccget nlandolt.dat output 03:55:00.0 0:00:00 1.0 1.0 \ +exprs="c[1-5]" +.fi + +Example 4. Repeat example 1 but extract the id, ra, dec, b and +b-r colors. Note that b and b-r are not columns in the input catalog +but may be computed from them. Note also that formats should be +specified to give the desired spacing, although defaults will be +supplied. + +.nf +cl> ccget nlandolt.dat output 03:55:00.0 0:00:00 1.0 1.0 \ +exprs="c[1-3],c4+c5,c5+c7" formats="%7.3f,%7.3f +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +.endhelp diff --git a/pkg/images/imcoords/doc/ccmap.hlp b/pkg/images/imcoords/doc/ccmap.hlp new file mode 100644 index 00000000..e19d30fa --- /dev/null +++ b/pkg/images/imcoords/doc/ccmap.hlp @@ -0,0 +1,1028 @@ +.help ccmap Jan01 images.imcoords +.ih +NAME +ccmap -- compute plate solutions using matched pixel and celestial coordinate +lists +.ih +USAGE +ccmap input database +.ih +PARAMETERS +.ls input +The input text files containing the pixel and celestial coordinates of +points in the input images. The coordinates are listed one per line with x, y, +ra / longitude, and dec / latitude in the columns specified by the +\fIxcolumn\fR, \fIycolumn\fR, \fIlngcolumn\fR, and \fIlatcolumn\fR parameters +respectively. Whether all files are combined to produce one solution or +each file produces a separate solution depends on whether there is a +matching list of output \fIsolutions\fR names or \fIresults\fR files. +.le +.ls database +The text database file where the computed plate solutions are stored. +.le +.ls solutions = "" +An optional list of plate solution names. If there are multiple input +coordinate files and no name or a single name is specified then the +input coordinates are combined to produce a single solution. Otherwise +the list must match the number of input coordinate files. If no names are +supplied then the database records are assigned the names of the input +images \fIimages\fR, or the names of the coordinate files \fIinput\fR. +In the case of multiple coordinate files the first image or input is used. +.le +.ls images = "" +The images associated with the input coordinate files. The number of images +must be zero or equal to the number of input coordinate files. If an input +image exists and the \fIupdate\fR parameter is enabled, the image wcs will +be created from the linear component of the computed plate solution +and written to the image header. +.le +.ls results = "" +Optional output files containing a summary of the results including a +description of the plate geometry and a listing of the input coordinates, +the fitted coordinates, and the fit residuals. The number of +results files must be zero, one or equal to the number of input files. If +results is "STDOUT" the results summary is printed on the standard output. +If there are multiple input coordinate files and zero or one output is +specified then the input coordinates are combined to produce a single solution. +.le +.ls xcolumn = 1, ycolumn = 2, lngcolumn = 3, latcolumn = 4 +The input coordinate file columns containing the x, y, ra / longitude and +dec / latitude values. +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The range of x and y pixel coordinates over which the computed coordinate +transformation is valid. These limits should be left at INDEF or set to +the values of the column and row limits of the input images, e.g xmin = 1.0, +xmax = 512, ymin= 1.0, ymax = 512 for a 512 x 512 image. If xmin, xmax, ymin, +or ymax are undefined, they are set to the minimum and maximum x and y +pixels values in \fIinput\fR. +.le +.ls lngunits = "", latunits = "" +The units of the input ra / longitude and dec / latitude coordinates. The +options are "hours", "degrees", and "radians" for ra / longitude, and +"degrees" and "radians" for dec / latitude. If the lngunits and latunits +are undefined they default to the preferred units for the coordinate system +specified by \fIinsystem\fR, e.g. "hours" and "degrees" for equatorial +systems, and "degrees" and "degrees" for ecliptic, galactic, and +supergalactic systems. +.le +.ls insystem = "j2000" +The input celestial coordinate system. The \fIinsystem\fR parameter +sets the preferred units for the input celestial coordinates, +tells CCMAP how to transform the celestial coordinates of the reference +point from the reference point coordinate system to the input coordinate +system, and sets the correct values of the image header keywords CTYPE, +RADECSYS, EQUINOX, and MJD-WCS if the image header wcs is updated. The +systems of most interest to users are "icrs", "j2000", and "b1950" which +stand for the ICRS J2000.0, FK5 J2000.0 and FK4 B1950.0 celestial coordinate +systems respectively. The full set of options are the following: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for the icrs, fk5, galactic, and supergalactic +coordinate systems is only used if the input coordinates are in the +equatorial fk4, noefk4, fk5, or icrs systems and proper motions are supplied. +Since CCMAP does not currently support proper motions these fields are +not required. +.le + +.ls refpoint = "coords" +The definition of the sky projection reference point in celestial coordinates, +e.g. the tangent point in the case of the usual tangent plane projection. +The options are: +.ls coords +The celestial coordinates of the reference point are set to the mean of the +input celestial coordinates, e.g. the mean of ra / longitude and dec / +latitude coordinates. If the true tangent point is reasonably close to +the center of the input coordinate distribution and the input is not +too large, this approximation is reasonably accurate. +.le +.ls user +The values of the keywords \fIlngref\fR, \fIlatref\fR, \fIrefsystem\fR, +\fIlngrefunits\fR, and \fIlatrefunits\fR are used to determine the celestial +coordinates of the reference point. +.le +.le +.ls xref = "INDEF", yref = "INDEF" +The reference pixel may be specified as a value or image header keyword. +In the latter case a reference image must be specified. By specifying +the reference pixel the solution will be constrained to putting the +reference coordinate at that point. +.le +.ls lngref = "INDEF", latref = "INDEF" +The ra / longitude and dec / latitude of the reference point(s). Lngref +and latref may be numbers, e.g 13:20:42.3 and -33:41:26 or keywords for the +appropriate parameters in the image header, e.g. RA/DEC or CRVAL1/CRVAL2. +Each parameter may be a list to apply different reference points to +each input coordinate list. If lngref and latref are undefined then +the position of the reference point defaults to the mean of the input +coordinates. +.le +.ls refsystem = "INDEF" +The celestial coordinate system of the reference point. Refsystem may +be any one of the options listed under the \fIinsystem\fR parameter, e.g. +"b1950", or an image header keyword containing the epoch of the observation +in years, e.g. EPOCH for NOAO data. In the latter case the coordinate system is +assumed to be equatorial FK4 at equinox EPOCH. If refsystem is undefined +the celestial coordinate system of the reference point defaults to the +celestial coordinate system of the input coordinates \fIinsystem\fR. +.le +.ls lngrefunits = "", latrefunits = "" +The units of the reference point celestial coordinates. The options +are "hours", "degrees", and "radians" for the ra / longitude coordinates, +and "degrees" and "radians" for the dec /latitude coordinates. +If lngunits and latunits are undefined they default to the units of the +input coordinate system. +.le +.ls projection = "tan" +The sky projection geometry. The most commonly used projections in astronomy +are "tan", "arc", "sin", and "lin". Other supported standard projections +are "ait", "car","csc", "gls", "mer", "mol", "par", "pco", "qsc", "stg", +"tsc", and "zea". A new experimental function "tnx", a combination of the +tangent plate projection and polynomials, is also available. +.le +.ls fitgeometry = "general" +The plate solution geometry to be used. The options are the following, where +xi and eta refer to the usual standard coordinates used in astrometry. +.ls shift +Xi and eta shifts only are fit. +.le +.ls xyscale +Xi and eta shifts and x and y magnification factors in " / pixel are fit. +Axis flips are allowed for. +.le +.ls rotate +Xi and eta shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +Xi and eta shifts, a magnification factor in " / pixel assumed to be the same +in x and y, and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +Xi and eta shifts, x and y magnifications factors in " / pixel, and a rotation +angle are fit. Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes a xi and eta +shift, an x and y scale factor in " / pixel, a rotation and a skew. Axis +flips are also allowed for in the linear portion of the fit. The distortion +term consists of a polynomial fit to the residuals of the linear term. By +default the distortion term is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are assumed to be set to "none", regardless of the values of the +\fIxxorder\fR, \fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR +and \fIyxterms\fR parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic coordinate surface to be fit. The options are the +following. +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series polynomials in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the xi and eta fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an xi and eta +shift, an x and y scaling in " / pixel, and rotations of the x and y axes. +The "shift", "xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1, xyorder - 1) for the xi fit and +MAX (yxorder - 1, yyorder - 1) for the eta fit. This is the recommended +option for higher order plate solutions. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1 + xyorder - 1) for the xi fit and +MAX (yxorder - 1 + yyorder - 1) for the eta fit. +.le + +The "shift", "xyscale", "rotation", +"rscale", and "rxyscale" fitting geometries, assume that the +cross term switches are set to "none" regardless of the values set by the user. +If either of the cross-terms parameters is set to "half" or "full" and +\fIfitgeometry\fR is "general" then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls maxiter = 0 +The maximum number of rejection iterations. The default is no rejection. +.le +.ls reject = INDEF +The rejection limit in units of sigma. +.le +.ls update = no +Update the world coordinate system in the input image headers ? +The required numerical quantities represented by the keywords CRPIX, +CRVAL, and CD are computed from the linear portion of the plate solution, +The values of the keywords CTYPE, RADECSYS, EQUINOX, and MJD-WCS +are set by the \fIprojection\fR and \fIinsystem\fR parameters. As there +is currently no standard mechanism for storing the higher order plate solution +terms if any in the image header wcs, these terms are currently ignored +unless the projection function is the experimental function "tnx". The "tnx" +function is not FITS compatible and can only be understood by IRAF. Any existing +image wcs represented by the above keywords is overwritten during the update. +.le +.ls pixsystem = "logical" +The input pixel coordinate system. The options are: +.ls logical +The logical pixel coordinate system is the coordinate system of the image +pixels on disk. Since most users measure the pixel coordinates of objects +in this system, "logical" is the system of choice for most applications. +.le +.ls physical +The physical coordinate system is the pixel coordinate system of the +parent image if any. This option may be useful for users working on images +that are pieces of a larger mosaic. +.le + +The choice of pixsystem has no affect on the fitting process, but does +determine how the image header wcs is updated. +.le +.ls verbose = yes +Print detailed messages about the progress of the task on the standard output ? +.le +.ls interactive = yes +Compute the plate solution interactively ? +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, reject points, display the data and refit, etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls cursor = "" +The graphics cursor. +.le +.ih +DESCRIPTION + +CCMAP computes the plate solution for an image or set of images using lists +of matched pixel and celestial coordinates. The celestial coordinates +are usually equatorial coordinates, but may also be ecliptic, galactic, +or supergalactic coordinates. The input coordinate files \fIinput\fR must +be text file tables whose columns are delimited by whitespace. The pixel +and celestial coordinates are listed in input, one per line with x, y, +ra / longitude, and dec / latitude in columns \fIxcolumn\fR, \fIycolumn\fR, +\fIlngcolumn\fR, and \fIlatcolumn\fR respectively. + +The \fIxmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR parameters define +the region of validity of the fit in the pixel coordinate system. They should +normally either be left set to INDEF, or set to the size of input images +\fIimages\fR if any, e.g. xmin= 1.0, xmax= 512.0, ymin = 1.0, ymax = 512.0 +for a 512 square image. If set these parameters are also used to reject out +of range pixel data before the actual fitting is done. + +The \fIlngunits\fR and \fIlatunits\fR parameters set the units of the input +celestial coordinates. If undefined lngunits and latunits assume sensible +defaults for the input celestial coordinate system set by the \fIinsystem\fR +parameter, e.g. "hours" and "degrees" for equatorial coordinates and "degrees" +and "degrees" for galactic coordinates. The input celestial coordinate system +must be one of the following: equatorial, ecliptic, galactic, or supergalactic. +The equatorial coordinate systems must be one of: 1) FK4, the mean place +pre-IAU 1976 system, 2) FK4-NO-E, the same as FK4 but without the E-terms, +3) FK5, the mean place post-IAU 1976 system, 4) GAPPT, the geocentric apparent +place in the post-IAU 1976 system. + +The plate solution computed by CCMAP has the following form, where x and y +are the pixel coordinates of points in the input image and xi and eta are the +corresponding standard coordinates in units of " / pixel. + +.nf + xi = f (x, y) + eta = g (x, y) +.fi + +The standard coordinates xi and eta are computed from the input celestial +coordinates using the sky projection geometry \fIprojection\fR and +the celestial coordinates of the projection reference point set by +the user. The default projection is the tangent plane or gnomonic +projection commonly used in optical astronomy. The projections most commonly +used in astronomy are "sin" (the orthographic projection, used in radio +aperture synthesis), "arc" (the zenithal equidistant projection, widely +used as an approximation for Schmidt telescopes), and "lin" (linear). +Other supported projections are "ait", "car", "csc", "gls", "mer", "mol", +"par", "pco", "qsc", "stg", "tsc", and "zea". The experimental projection +function "tnx" combines the "tan" projection with a polynomial fit +to the residuals can be used to represent more complicated distortion +functions. + +There are two modes in which this task works with multiple input +coordinate lists. In one case each input list and possible associated +image is treated independently and produce separate solutions. To +select this option requires specifying a matching list of solution +names or output results files. Note that this can also be simply done +by running the task multiple times with a single input list each time. + +In the second mode data from multiple input lists are combined to +produce a single solution. This is useful when multiple exposures are +taken to define a higher quality astrometric solution. This mode is +selected when there are multiple input lists, and possibly associated +images, and no solution name or a single solution name is specified. + +When combining input data each set of coordinates may have different +reference points which can be specified either as a list or by +reference to image header keywords. The different reference points +are used to convert each set of coordinates to the same coordinate +frame. Typically this occurs when a set of exposures, each with the +same coordinate reference pixel, has slightly different pointing as +defined by the coordinate reference value. These different points +result from a dither and can be useful to more completely sample the +image pixel space. In other words, astrometric reference stars can be +moved around the images to produce many more fitting points than occur +with a single exposure. The key point to this process is that the +shifts are mapped by the reference points of the pointing and the +standard coordinates are independent of the pointing. + +A particular feature primarily intending for combining multiple +exposures, but applies to single exposures as well, is an adjustment to +the specified tangent point value based on the image WCS. When images, +reference pixels, and reference coordinates are all defined and the +images contain a celestial WCS the following computation is performed. +The reference information replaces the WCS tangent point values, though +typically the initial reference information is specified as the tangent +point, and the updated WCS is used to evaluate celestial coordinates +from the input pixel coordinates. The average difference between the WCS +evaluated coordinates and the input celestial coordinates is computed. +This difference is applied to the reference point prior to the standard +coordinate plate solution calculation. In other words, the reference +point is tweaked in the initial image WCS to make it agree on average with +the input reference coordinates. If one updates the WCS of the images by +the plate solution and the repeats the plate solution, particularly when +using multiple exposures, an iterative convergence to a self-consistent +WCS of both the tangent point and plate solution can be obtained. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xi = a11 + a21 * x + a12 * y + + a31 * x ** 2 + a13 * y ** 2 + eta = a11' + a21' * x + a12' * y + + a31' * x ** 2 + a13' * y ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xi = a11 + a21 * x + a12 * y + + a31 * x ** 2 + a22 * x * y + a13 * y ** 2 + eta = a11' + a21' * x + a12' * y + + a31' * x ** 2 + a22' * x * y + a13' * y ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xi = a11 + a21 * x + a31 * x ** 2 + + a12 * y + a22 * x * y + a32 * x ** 2 * y + + a13 * y ** 2 + a23 * x * y ** 2 + a33 * x ** 2 * y ** 2 + eta = a11' + a21' * x + a31' * x ** 2 + + a12' * y + a22' * x * y + a32' * x ** 2 * y + + a13' * y ** 2 + a23' * x * y ** 2 + a33' * x ** 2 * y ** 2 +.fi + +If \fIrefpoint\fR is "coords", then the sky projection reference point is set +to the mean of the input celestial coordinates. For images where the true +reference point is close to the center of the input coordinate distribution, +this definition is adequate for many purposes. If \fIrefpoint\fR is "user", +the user may either set the celestial coordinates of the reference +point explicitly, e.g. \fIlngref\fR = 13:41:02.3 and \fIlatref\fR = -33:42:20, +or point these parameters to the appropriate keywords in the input image +header, e.g. \fIlngref\fR = RA, \fIlatref\fR = DEC for NOAO image data. +If undefined the celestial coordinate system of the reference point +\fIrefsystem\fR defaults to the celestial coordinate system of the input +coordinates, otherwise it be any of the supported celestial coordinate +systems described above. The user may also set \fIrefsystem\fR to the +image header keyword containing the epoch of the celestial reference point +coordinates in years, e.g. EPOCH for NOAO data. In this case the +reference point coordinates are assumed to be equatorial FK4 coordinates at the +epoch specified by EPOCH. The units of the reference point celestial +coordinates are specified by the \fIlngrefunits\fR and \fIlatrefunits\fR +parameters. Lngrefunits and latrefunits default to the values of the input +coordinate units if undefined by either the user or the \fIrefsystem\fR +parameter. ONCE DETERMINED THE REFERENCE POINT CANNOT BE RESET DURING +THE FITTING PROCESS. + +The \fIxref\fR and \fIyref\fR parameters may be used to constrain the +solution to putting the reference coordinate at the reference pixel. +Effectively what this does is fix the zero-th order coefficient in the +linear part of the solution. If a reference pixel is not specified the +solution will produce a point determined from the zero-th order +constant coefficient. This may not be what is expected based on +the specified reference celestial coordinate. + +The fitting functions f and g are specified by the \fIfunction\fR parameter +and may be power series polynomials, Legendre polynomials, or Chebyshev +polynomials of order \fIxxorder\fR and \fIxyorder\fR in x and \fIyxorder\fR +and \fIyyorder\fR in y. Cross-terms are optional and are turned on and +off by setting the \fIxxterms\fR and \fIxyterms\fR parameters. If the +\fBfitgeometry\fR parameter is anything other than "general", the order +parameters assume the value 2 and the cross-terms switches assume the value +"none", regardless of the values set by the user. All computation are done in +double precision. Automatic pixel rejection may be enabled by setting +\fImaxiter\fR > 0 and \fIreject\fR to a positive value, usually something +in the range 2.5-5.0. + +CCMAP may be run interactively by setting \fIinteractive\fR to "yes" and +inputting commands by the use of simple keystrokes. In interactive mode the +user has the option of changing the fitting parameters and displaying the +data and fit graphically until a satisfactory fit has been achieved. The +keystroke commands are listed below. + +.nf + +? Print options +f Fit data and graph fit with the current graph type (g,x,r,y,s) +g Graph the data and the current fit +x,r Graph the xi residuals versus x and y respectively +y,s Graph the eta residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the line of constant x and y plotting option +t Plot a line of constant x and y through nearest data point +l Print xishift, etashift, xscale, yscale, xrotate, yrotate +q Exit the interactive fitting code +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name along will list the current value. + +.nf +:show List parameters +:projection Sky projection +:refpoint Sky projection reference point +:fit [value] Fit type (shift,xyscale,rotate,rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre,polynomial) +:xxorder [value] Xi fitting function order in x +:xyorder [value] Xi fitting function order in y +:yxorder [value] Eta fitting function order in x +:yyorder [value] Eta fitting function order in y +:xxterms [n/h/f] The xi fit cross terms type +:yxterms [n/h/f] The eta fit cross terms type +:maxiter [value] Maximum number of rejection iterations +:reject [value] K-sigma rejection threshold +.fi + +The final fit is stored in the text database file \fIdatabase\fR file in a +format suitable for use by the CCSETWCS and CCTRAN tasks. Each fit is +stored in a record whose name is the name of the input image \fIimage\fR +if one is supplied, or the name of the input coordinate file \fIinput\fR. + +If the \fIupdate\fR switch is "yes" and an input image is specified, +a new image wcs is derived from the linear component of the computed plate +solution and written to the image header. The numerical components of +the new image wcs are written to the standards FITS keywords, CRPIX, CRVAL, +and CD, with the actual values depending on the input pixel coordinate +system \fIpixsystem\fR. +The FITS keywords which define the image celestial coordinate +system CTYPE, RADECSYS, EQUINOX, and MJD-WCS are set by the \fIinsystem\fR and +\fIprojection\fR parameters. + +The first four characters of the values of the ra / longitude and dec / latitude +axis CTYPE keywords specify the celestial coordinate system. They are set to +RA-- / DEC- for equatorial coordinate systems, ELON / ELAT for the ecliptic +coordinate system, GLON / GLAT for the galactic coordinate system, and +SLON / SLAT for the supergalactic coordinate system. + +The second four characters of the values of the ra / longitude and dec / +latitude axis CTYPE keywords specify the sky projection geometry. IRAF +currently supports the TAN, SIN, ARC, AIT, CAR, CSC, GLS, MER, MOL, PAR, PCO, +QSC, STG, TSC, and ZEA standard projections, in which case the second 4 +characters of CTYPE are set to -TAN, -ARC, -SIN, etc. IRAF and CCMAP also +support the experiment TAN plus polynomials function driver. + +If the input celestial coordinate system is equatorial, the value of the +RADECSYS keyword specifies the fundamental equatorial system, EQUINOX +specifies the epoch of the mean place, and MJD-WCS specifies the epoch +for which the mean place is correct. The permitted values of +RADECSYS are FK4, FK4-NO-E, FK5, ICRS, and GAPPT. EQUINOX is entered in years +and interpreted as a Besselian epoch for the FK4 system, a Julian epoch +for the FK5 system. The epoch of the wcs MJD-WCS is entered as +a modified Julian date. Only those keywords necessary to defined the +new wcs are written. Any existing keywords which are not required to +define the wcs or are redundant are removed, with the exception of +DATE-OBS and EPOCH, which are left unchanged for obvious (DATE_OBS) and +historical (use of EPOCH keyword at NOAO) reasons. + +If \fIverbose\fR is "yes", various pieces of useful information are +printed to the terminal as the task proceeds. If \fIresults\fR is set to a +file name then the original pixel and celestial coordinates, the fitted +celestial coordinates, and the residuals of the fit in arcseconds are written +to that file. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not correspond to a physically meaningful model. However the computed +coefficients for the linear term can be given a simple geometrical +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xi = a + b * x + c * y + eta = d + e * x + f * y + + fitting geometry = shift + xi = a + x + eta = d + y + + fitting geometry = xyscale + xi = a + b * x + eta = d + f * y + + fitting geometry = rotate + xi = a + b * x + c * y + eta = d + e * x + f * y + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xi = a + b * x + c * y + eta = d + e * x + f * y + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xi = a + b * x + c * y + eta = d + e * x + f * y + b * f - c * e = +/- const +.fi + +The coefficients can be interpreted as follows. X0, y0, xi0, eta0 +are the origins in the reference and input frames respectively. By definition +xi0 and eta0 are 0.0 and 0.0 respectively. Rotation and skew are the rotation +of the x and y axes and their deviation from perpendicularity respectively. +Xmag and ymag are the scaling factors in x and y in " / pixel and are assumed +to be positive by definition. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * x0 - c * y0 = xshift + d = eta0 - e * x0 - f * y0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xi0 - x0 = xshift + d = eta0 - y0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xi0 - b * x0 = xshift + d = eta0 - f * y0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xi0 - b * x0 - c * y0 = xshift + d = eta0 - e * x0 - f * y0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * x0 - c * y0 = xshift + d = eta0 - e * x0 - f * y0 = yshift +.fi + +.ih +REFERENCES + + +Additional information on the IRAF world coordinate systems can be found in +the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + + + +.ih +EXAMPLES + +1. Compute the plate scale for the test image dev$pix given the following +coordinate list. Set the tangent point to the mean of the input celestial +coordinates. Compute the plate scale interactively. + +.nf +cl> type coords + +13:29:47.297 47:13:37.52 327.50 410.38 +13:29:37.406 47:09:09.18 465.50 62.10 +13:29:38.700 47:13:36.23 442.01 409.65 +13:29:55.424 47:10:05.15 224.35 131.20 +13:30:01.816 47:12:58.79 134.37 356.33 + +cl> imcopy dev$pix pix + +cl> hedit pix epoch 1987.26 + +cl> ccmap coords coords.db image=pix xcol=3 ycol=4 lngcol=1 latcol=2 + + ... a plot of the mapping function appears + ... type ? to see the list of commands + ... type x to see the xi fit residuals versus x + ... type r to see the xi fit residuals versus y + ... type y to see the eta fit residuals versus x + ... type s to see the eta fit residuals versus y + ... type g to return to the default plot + ... type l to see the computed x and y scales in " / pixel + ... type q to quit and save fit +.fi + +2. Repeat example 2 but compute the fit non-interactively and list the +fitted values of the ra and dec and their residuals on the standard +output. + +.nf +cl> ccmap coords coords.db image=pix results=STDOUT xcol=3 ycol=4 \ +lngcol=1 latcol=2 inter- + +# Coords File: coords Image: pix +# Database: coords.db Record: pix +# Refsystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Coordinate mapping status +# XI fit ok. ETA fit ok. +# Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +# Coordinate mapping parameters +# Sky projection geometry: tan +# Reference point: 13:29:48.129 47:11:53.37 (hours degrees) +# Reference point: 318.735 273.900 (pixels pixels) +# X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) +# X and Y axis rotation: 179.110 358.958 (degrees degrees) +# Wcs mapping status +# Ra/Dec or Long/Lat wcs rms: 0.229 0.241 (arcsec arcsec) +# +# Input Coordinate Listing +# X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec +# +327.5 410.4 13:29:47.30 47:13:37.5 13:29:47.28 47:13:37.9 0.128 -0.370 +465.5 62.1 13:29:37.41 47:09:09.2 13:29:37.42 47:09:09.2 -0.191 -0.062 +442.0 409.6 13:29:38.70 47:13:36.2 13:29:38.70 47:13:35.9 0.040 0.282 +224.3 131.2 13:29:55.42 47:10:05.2 13:29:55.40 47:10:05.1 0.289 0.059 +134.4 356.3 13:30:01.82 47:12:58.8 13:30:01.84 47:12:58.7 -0.267 0.091 +.fi + +3. Repeat the previous example but in this case input the position of the +tangent point in fk4 1950.0 coordinates. + +.nf +cl> ccmap coords coords.db image=pix results=STDOUT xcol=3 ycol=4 lngcol=1 \ +latcol=2 refpoint=user lngref=13:27:46.9 latref=47:27:16 refsystem=b1950.0 \ +inter- + +# Coords File: coords Image: pix +# Database: coords.db Record: pix +# Refsystem: b1950.0 Coordinates: equatorial FK4 +# Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Coordinate mapping status +# XI fit ok. ETA fit ok. +# Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +# Coordinate mapping parameters +# Sky projection geometry: tan +# Reference point: 13:29:53.273 47:11:48.36 (hours degrees) +# Reference point: 250.256 266.309 (pixels pixels) +# X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) +# X and Y axis rotation: 179.126 358.974 (degrees degrees) +# Wcs mapping status +# Ra/Dec or Long/Lat wcs rms: 0.229 0.241 (arcsec arcsec) +# +# Input Coordinate Listing +# X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec + +327.5 410.4 13:29:47.30 47:13:37.5 13:29:47.28 47:13:37.9 0.128 -0.370 +465.5 62.1 13:29:37.41 47:09:09.2 13:29:37.42 47:09:09.2 -0.191 -0.062 +442.0 409.6 13:29:38.70 47:13:36.2 13:29:38.70 47:13:35.9 0.040 0.282 +224.3 131.2 13:29:55.42 47:10:05.2 13:29:55.40 47:10:05.1 0.289 0.059 +134.4 356.3 13:30:01.82 47:12:58.8 13:30:01.84 47:12:58.7 -0.267 0.091 +.fi + +Note the computed image scales are identical in examples 2 and 3 but that +the assumed position of the tangent point is different (the second estimate +is more accurate) producing different values for the pixel and celestial +coordinates of the reference point and small differences in the computed +rotation angles. + +4. Repeat the previous example but in this case extract the position of the +tangent point in from the image header keywords RA, DEC, and EPOCH. + +.nf +cl> imheader pix l+ + +... +DATE-OBS= '05/04/87' / DATE DD/MM/YY +RA = '13:29:24.00' / RIGHT ASCENSION +DEC = '47:15:34.00' / DECLINATION +EPOCH = 1987.26 / EPOCH OF RA AND DEC +... + +cl> ccmap coords coords.db image=pix results=STDOUT xcol=3 ycol=4 \ +lngcol=1 latcol=2 refpoint=user lngref=RA latref=DEC refsystem=EPOCH \ +inter- + +# Coords File: coords Image: pix +# Database: coords.db Record: pix +# Refsystem: fk4 b1987.26 Coordinates: equatorial FK4 +# Equinox: B1987.260 Epoch: B1987.26000000 MJD: 46890.84779 +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Coordinate mapping status +# XI fit ok. ETA fit ok. +# Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +# Coordinate mapping parameters +# Sky projection geometry: tan +# Reference point: 13:29:56.232 47:11:38.19 (hours degrees) +# Reference point: 211.035 252.447 (pixels pixels) +# X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) +# X and Y axis rotation: 179.135 358.983 (degrees degrees) +# Wcs mapping status +# Ra/Dec or Long/Lat wcs rms: 0.229 0.241 (arcsec arcsec) +# +# Input Coordinate Listing +# X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec + +327.5 410.4 13:29:47.30 47:13:37.5 13:29:47.28 47:13:37.9 0.128 -0.370 +465.5 62.1 13:29:37.41 47:09:09.2 13:29:37.42 47:09:09.2 -0.191 -0.062 +442.0 409.6 13:29:38.70 47:13:36.2 13:29:38.70 47:13:35.9 0.040 0.282 +224.3 131.2 13:29:55.42 47:10:05.2 13:29:55.40 47:10:05.1 0.289 0.059 +134.4 356.3 13:30:01.82 47:12:58.8 13:30:01.84 47:12:58.7 -0.267 0.091 + +.fi + +Note that the position of the tangent point is slightly different again but +that this does not have much affect on the fitted coordinates for this image. + +5. Repeat the third example but this time store the computed world coordinate +system in the image header and check the header update with the imheader and +skyctran tasks. + +.nf +cl> imheader pix l+ +... +DATE-OBS= '05/04/87' / DATE DD/MM/YY +RA = '13:29:24.00' / RIGHT ASCENSION +DEC = '47:15:34.00' / DECLINATION +EPOCH = 1987.26 / EPOCH OF RA AND DEC +... + +cl> ccmap coords coords.db image=pix results=STDOUT xcol=3 ycol=4 \ +lngcol=1 latcol=2 refpoint=user lngref=13:27:46.9 latref=47:27:16 \ +refsystem=b1950.0 inter- update+ + +# Coords File: coords Image: pix +# Database: coords.db Record: pix +# Refsystem: b1950.0 Coordinates: equatorial FK4 +# Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 +# Insystem: j2000 Coordinates: equatorial FK5 +# Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +# Coordinate mapping status +# Coordinate mapping status +# XI fit ok. ETA fit ok. +# Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +# Coordinate mapping parameters +# Sky projection geometry: tan +# Reference point: 13:29:53.273 47:11:48.36 (hours degrees) +# Reference point: 250.256 266.309 (pixels pixels) +# X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) +# X and Y axis rotation: 179.126 358.974 (degrees degrees) +# Wcs mapping status +# Ra/Dec or Long/Lat wcs rms: 0.229 0.241 (arcsec arcsec) +# Updating image header wcs +# +# +# Input Coordinate Listing +# X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec + +327.5 410.4 13:29:47.30 47:13:37.5 13:29:47.28 47:13:37.9 0.128 -0.370 +465.5 62.1 13:29:37.41 47:09:09.2 13:29:37.42 47:09:09.2 -0.191 -0.062 +442.0 409.6 13:29:38.70 47:13:36.2 13:29:38.70 47:13:35.9 0.040 0.282 +224.3 131.2 13:29:55.42 47:10:05.2 13:29:55.40 47:10:05.1 0.289 0.059 +134.4 356.3 13:30:01.82 47:12:58.8 13:30:01.84 47:12:58.7 -0.267 0.091 + +cl> imheader pix l+ +... +DATE-OBS= '05/04/87' / DATE DD/MM/YY +RA = '13:29:24.00' / RIGHT ASCENSION +DEC = '47:15:34.00' / DECLINATION +EPOCH = 1987.26 / EPOCH OF RA AND DEC +... +RADECSYS= 'FK5 ' +EQUINOX = 2000. +MJD-WCS = 51544.5 +WCSDIM = 2 +CTYPE1 = 'RA---TAN' +CTYPE2 = 'DEC--TAN' +CRVAL1 = 202.471969550729 +CRVAL2 = 47.1967667056819 +CRPIX1 = 250.255619786203 +CRPIX2 = 266.308757328719 +CD1_1 = -2.1224568721716E-4 +CD1_2 = -3.8136850875221E-6 +CD2_1 = -3.2384199624421E-6 +CD2_2 = 2.12935798198448E-4 +LTM1_1 = 1. +LTM2_2 = 1. +WAT0_001= 'system=image' +WAT1_001= 'wtype=tan axtype=ra' +WAT2_001= 'wtype=tan axtype=dec' +... + +cl> skyctran coords STDOUT "pix log" "pix world" lngcol=3 latcol=4 trans+ + +# Insystem: pix logical Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 +# Outsystem: pix world Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 + +# Input file: incoords Output file: STDOUT + +13:29:47.297 47:13:37.52 13:29:47.284 47:13:37.89 +13:29:37.406 47:09:09.18 13:29:37.425 47:09:09.24 +13:29:38.700 47:13:36.23 13:29:38.696 47:13:35.95 +13:29:55.424 47:10:05.15 13:29:55.396 47:10:05.09 +13:30:01.816 47:12:58.79 13:30:01.842 47:12:58.70 + +.fi + +Note that two versions of the rms values are printed, one for the fit +and one for the wcs fit. For the default fitting parameters these +two estimates should be identical. If a non-linear high order plate +solution is requested however, the image wcs will have lower precision +than the than the full plate solution, because only the linear component +of the plate solution is preserved in the wcs. + +.ih +BUGS + +.ih +SEE ALSO +cctran,ccsetwcs,skyctran,imctran,finder.tfinder,finder.tastrom +.endhelp diff --git a/pkg/images/imcoords/doc/ccsetwcs.hlp b/pkg/images/imcoords/doc/ccsetwcs.hlp new file mode 100644 index 00000000..b5700cbc --- /dev/null +++ b/pkg/images/imcoords/doc/ccsetwcs.hlp @@ -0,0 +1,562 @@ +.help ccsetwcs Jun99 images.imcoords +.ih +NAME +ccsetwcs -- create an image wcs from a plate solution +.ih +USAGE +ccsetwcs image database solutions +.ih +PARAMETERS +.ls images +The input images for which the wcs is to be created. +.le +.ls database +The text database file written by the ccmap task containing the +plate solutions. If database is undefined ccsetwcs computes +the image wcs using the xref, yref, xmag, ymag, xrotation, yrotation, +lngref, latref, lngrefunits, latrefunits, and projection parameters. +.le +.ls solutions +The list of plate solutions. The number of plate solutions must be one +or equal to the number of input images. Solutions is either a user name +supplied to the ccmap task, or the +name of the ccmap task input image for which the plate solution is valid, +or the name of the coordinate file that the ccmap task used to compute the +plate solution. The quantities stored in transform always supersede the +values of the xref, yref, xmag, ymag, xrotation, yrotation, lngref, latref, +lnrefunits, latrefunits, and projection parameters. +.le +.ls xref = INDEF, yref = INDEF +The x and y pixel coordinates of the sky projection reference point. +If database is undefined then xref and yref default to the center of the +image in pixel coordinates, otherwise these parameters are ignored. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in arcseconds per pixel. If database is undefined +xmag and ymag default to 1.0 and 1.0 arcsec / pixel, otherwise these parameters +are ignored. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles in degrees measured counter-clockwise with +respect to the x and y axes. Xrotation and yrotation are interpreted as the +rotation of the coordinates with respect to the x and y axes and default 0.0 +and 0.0 degrees. For example xrotation and yrotation values of 30.0 and 30.0 +will rotate a point 30 degrees counter-clockwise with respect to the x and y +axes. To flip the x axis coordinates in this case either set the angles to +210.0 and 30.0 degrees or leave the angles set to 30.0 and 30.0 and set the +xmag parameter to a negative value. To set east to the up, down, left, and +right directions, set xrotation to 90, 270, 180, and 0 respectively. To set +north to the up, down, left, and right directions, set yrotation to 0, 180, +90, and 270 degrees respectively. Any global rotation must be added to both the +xrotation and yrotation values. +.le +.ls lngref = INDEF, latref = INDEF +The celestial coordinates of the sky projection reference point, e.g. +the ra and dec of the reference point for equatorial systems. If database is +undefined lngref and latref default to 0.0 and 0.0, otherwise these parameters +are ignored. +.le +.ls lngunits = "", latunits = "" +The units of the lngref and latref parameters. +The options are "hours", "degrees", "radians" for the ra / longitude +coordinates, and "degrees" and "radians" for the dec / latitude coordinates. +If database is undefined then lngunits and latunits default to the preferred +units for the celestial coordinate system defined by the \fIcoosystem\fR +parameter, otherwise these parameters are ignored. +.le +.ls transpose = no +Transpose the newly created image wcs ? +.le +.ls projection = "tan" +The sky projection geometry. The most commonly used projections in +astronomy are "tan", "arc", "sin", and "lin". Other supported projections +are "ait", "car", "csc", "gls", "mer", "mol", "par", "pco", "qsc", "stg", +"tsc", and "zea". +.le +.ls coosystem = "j2000" +The celestial coordinate system. The systems of most interest to users +are "icrs", "j2000" and "b1950" which stand for the ICRS J2000.0, FK5 J2000.0, +and FK4 B1950.0 celestial coordinate systems respectively. The full set of +options are listed below. The celestial coordinate system sets the preferred +units for the lngref and latref parameters and the correct values of the image +wcs header keywords CTYPE, RADECSYS, EQUINOX, and MJD-WCS if the image header +wcs is updated. If database is undefined the coosystem parameter is used, +otherwise this parameter is ignored. + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for icrs, fk5, galactic, and supergalactic +coordinate systems is required only if the input coordinates are in the +equatorial fk4, noefk4, fk5, or icrs systems and proper motions are defined. +.le +.ls update = yes +Update the world coordinate system in the input image headers ? +The numerical quantities represented by the keywords CRPIX, +CRVAL, and CD are computed from the linear portion of the plate solution. +The values of the keywords CTYPE, RADECSYS, EQUINOX, and MJD-WCS +are set by the \fIprojection\fR and \fIcoosystem\fR parameters if database +is undefined, otherwise projection and coosystem are read from the plate +solution. As there is currently no standard mechanism for storing the higher +order plate solution terms if any in the image header wcs, these terms are +ignored. Any existing image wcs represented by the above keywords is +overwritten during the update. +.le +.ls pixsystem = "logical" +The pixel coordinate system. The options are: +.ls logical +The logical pixel coordinate system is the coordinate system of the image +pixels on disk. Since most users measure the pixel coordinates of objects +in this system, "logical" is the system of choice for most applications. +.le +.ls physical +The physical coordinate system is the pixel coordinate system of the +parent image. This option is useful for users working on images that are +pieces of a larger mosaic. +.le + +The pixsystem parameter is only used if no database solution is specified. +Otherwise pixsystem is read from the database file. +.le +.ls verbose = yes +Print detailed messages about the progress of the task on the standard output ? +.le + +.ih +DESCRIPTION + +CCSETWCS creates an image world coordinate system from the plate solution +computed by the CCMAP task or supplied by the user, and writes it to the +headers of the input images \fIimages\fR if the \fIupdate\fR parameter is yes. + +The plate solution can either be read from record \fIsolutions\fR in the +database file \fIdatabase\fR written by CCMAP, or specified by the user +via the \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +\fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, \fIlngunits\fR, \fIlatunits\fR, +\fItranspose\fR, \fIprojection\fR, \fIcoosystem\fR and \fIpixsystem\fR +parameters. + +The plate solution computed by CCMAP has the following form where x and y +are the image pixel coordinates and xi and eta are the corresponding standard +coordinates in arcseconds per pixel. The standard coordinates are computed +by applying the appropriate sky projection to the celestial coordinates. + + +.nf + xi = f (x, y) + eta = g (x, y) +.fi + +The functions f and g are either power series, Legendre, or Chebyshev +polynomials whose order and region of validity were set by the user when +CCMAP was run. The computed plate solution is somewhat arbitrary and does +not correspond to any physically meaningful model. However the linear +component of the plate solution can be given the simple geometrical +interpretation shown below. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +xref, yref, xi0, and eta0 are the origins of the pixel and standard +coordinate systems respectively. xmag and ymag are the x and y scale factors +in " / pixel and xrotation and yrotation are the rotation angles measured +counter-clockwise of the x and y axes. + +If the CCMAP database is undefined then CCSETWCS computes a linear plate +solution using the parameters \fIxref\fR, \fIyref\fR, \fIxmag\fR, +\fIymag\fR, \fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +\fIlngunits\fR, \fIlatunits\fR, \fItranspose\fR, and +\fIprojection\fR as shown below. Note that in this case +xrotation and yrotation are interpreted as the rotation of the coordinates +themselves not the coordinate axes. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +The \fItranspose\fR parameter can be used to transpose the newly created +image wcs. + +If the \fIupdate\fR switch is "yes" and an input image is specified, +a new image wcs is derived from the linear component of the computed plate +solution and written to the image header. The numerical components of +the new image wcs are written to the standards FITS keywords, CRPIX, CRVAL, +and CD, with the actual values depending on the pixel coordinate system +\fIpixsystem\fR read from the database or set by the user. The FITS keywords +which define the image celestial coordinate system CTYPE, RADECSYS, EQUINOX, +and MJD-WCS are set by the \fIcoosystem\fR and \fIprojection\fR parameters. + +The first four characters of the values of the ra / longitude and dec / latitude +axis CTYPE keywords specify the celestial coordinate system. They are set to +RA-- / DEC- for equatorial coordinate systems, ELON / ELAT for the ecliptic +coordinate system, GLON / GLAT for the galactic coordinate system, and +SLON / SLAT for the supergalactic coordinate system. + +The second four characters of the values of the ra / longitude and dec / +latitude axis CTYPE keywords specify the sky projection geometry. +The second four characters of the values of the ra / longitude and dec / +latitude axis CTYPE keywords specify the sky projection geometry. IRAF +currently supports the TAN, SIN, ARC, AIT, CAR, CSC, GLS, MER, MOL, PAR, PCO, +QSC, STG, TSC, and ZEA standard projections, in which case the second 4 +characters of CTYPE are set to -TAN, -ARC, -SIN, etc. + +If the input celestial coordinate system is equatorial, the value of the +RADECSYS keyword specifies the fundamental equatorial system, EQUINOX +specifies the epoch of the mean place, and MJD-WCS specifies the epoch +for which the mean place is correct. The permitted values of +RADECSYS are FK4, FK4-NO-E, FK5, ICRS, and GAPPT. EQUINOX is entered in years +and interpreted as a Besselian epoch for the FK4 system, a Julian epoch +for the FK5 and ICRS system. The epoch of the wcs MJD-WCS is entered as +a modified Julian date. Only those keywords necessary to defined the +new wcs are written. Any existing keywords which are not required to +define the wcs or are redundant are removed, with the exception of +DATE-OBS and EPOCH, which are left unchanged for obvious (DATE-OBS) and +historical (use of EPOCH keyword at NOAO) reasons. + +If \fIverbose\fR is "yes", various pieces of useful information are +printed to the terminal as the task proceeds. + +.ih +REFERENCES + +Additional information on the IRAF world coordinate systems can be found in +the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + + + +.ih +EXAMPLES + +1. Compute the plate solution for an image with the ccmap task and then +use the ccsetwcs task to create the image wcs. Check the results with the +imheader and skyctran tasks. + +.nf +cl> type coords +13:29:47.297 47:13:37.52 327.50 410.38 +13:29:37.406 47:09:09.18 465.50 62.10 +13:29:38.700 47:13:36.23 442.01 409.65 +13:29:55.424 47:10:05.15 224.35 131.20 +13:30:01.816 47:12:58.79 134.37 356.33 + + +cl> ccmap coords coords.db image=pix xcol=3 ycol=4 lngcol=1 latcol=2 \ +inter- +Coords File: coords Image: pix + Database: coords.db Record: pix +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Coordinate mapping status + Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:48.129 47:11:53.37 (hours degrees) + Reference point: 318.735 273.900 (pixels pixels) + X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 179.110 358.958 (degrees degrees) +Wcs mapping status + Ra/Dec or Long/Lat wcs rms: 0.229 0.241 (arcsec arcsec) + +cl> type coords.db +# Mon 15:10:37 13-May-96 +begin coords + xrefmean 318.7460000000001 + yrefmean 273.9320000000001 + lngmean 13.49670238888889 + latmean 47.19815944444444 + coosystem j2000 + projection tan + lngref 13.49670238888889 + latref 47.19815944444444 + lngunits hours + latunits degrees + xpixref 318.7352667484295 + ypixref 273.9002619912411 + geometry general + function polynomial + xishift 247.3577084680361 + etashift -206.1795977453246 + xmag 0.7641733802338992 + ymag 0.7666917500560622 + xrotation 179.1101291109185 + yrotation 358.9582148846163 + wcsxirms 0.2288984454992771 + wcsetarms 0.2411034140453112 + xirms 0.2288984454992771 + etarms 0.2411034140453112 + surface1 11 + 3. 3. + 2. 2. + 2. 2. + 0. 0. + 134.3700000000001 134.3700000000001 + 465.5000000000002 465.5000000000002 + 62.1 62.1 + 410.3800000000001 410.3800000000001 + 247.3577084680361 -206.1795977453246 + -0.7640812161068504 -0.011868034832272 + -0.01393966623835092 0.7665650170136847 + surface2 0 + + + +cl> imheader pix l+ +... +DATE-OBS= '05/04/87' / DATE DD/MM/YY +RA = '13:29:24.00' / RIGHT ASCENSION +DEC = '47:15:34.00' / DECLINATION +EPOCH = 1987.26 / EPOCH OF RA AND DEC +... + + +cl> ccsetwcs pix coords.db pix +Image: pix Database: coords.db Record: pix +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:48.129 47:11:53.37 (hours degrees) + Ra/Dec logical image axes: 1 2 + Reference point: 318.735 273.900 (pixels pixels) + X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) + X and Y coordinate rotation: 179.110 358.958 (degrees degrees) +Updating image header wcs + +cl> imheader pix l+ +... +DATE-OBS= '05/04/87' / DATE DD/MM/YY +RA = '13:29:24.00' / RIGHT ASCENSION +DEC = '47:15:34.00' / DECLINATION +EPOCH = 1987.26 / EPOCH OF RA AND DEC +... +RADECSYS= 'FK5 ' +EQUINOX = 2000. +MJD-WCS = 51544.5 +WCSDIM = 2 +CTYPE1 = 'RA---TAN' +CTYPE2 = 'DEC--TAN' +CRVAL1 = 202.450535833334 +CRVAL2 = 47.1981594444445 +CRPIX1 = 318.735266748429 +CRPIX2 = 273.900261991241 +CD1_1 = -2.1224478225190E-4 +CD1_2 = -3.8721295106530E-6 +CD2_1 = -3.2966763422978E-6 +CD2_2 = 2.12934726948246E-4 +LTM1_1 = 1. +LTM2_2 = 1. +WAT0_001= 'system=image' +WAT1_001= 'wtype=tan axtype=ra' +WAT2_001= 'wtype=tan axtype=dec' + +cl> skyctran coords STDOUT "pix log" "pix world" lngcol=3 latcol=4 trans+ + +# Insystem: pix logical Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 +# Outsystem: pix world Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 + +# Input file: incoords Output file: STDOUT + +13:29:47.297 47:13:37.52 13:29:47.284 47:13:37.89 +13:29:37.406 47:09:09.18 13:29:37.425 47:09:09.24 +13:29:38.700 47:13:36.23 13:29:38.696 47:13:35.95 +13:29:55.424 47:10:05.15 13:29:55.396 47:10:05.09 +13:30:01.816 47:12:58.79 13:30:01.842 47:12:58.70 +.fi + +The skyctran task is used to test that the input image wcs is indeed correct. +Columns 1 and 2 contain the original ra and dec values and columns 3 and 4 +contain the transformed values. The second imheader listing shows what the +image wcs looks like. + + +2. Repeat the previous example but enter the plate solution parameters by +hand. + +.nf +cl> ccsetwcs pix "" xref=318.735 yref=273.900 lngref=13:29:48.129 \ +latref=47:11:53.37 xmag=.764 ymag=.767 xrot=180.890 yrot=1.042 +Image: pix +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:48.129 47:11:53.37 (hours degrees) + Ra/Dec logical image axes: 1 2 + Reference point: 318.735 273.900 (pixels pixels) + X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) + X and Y coordinate rotation: 180.890 1.042 (degrees degrees) +Updating image header wcs + + +cl> skyctran coords STDOUT "pix log" "pix world" lngcol=3 latcol=4 trans+ + +# Insystem: pix logical Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 +# Outsystem: pix world Projection: TAN Ra/Dec axes: 1/2 +# Coordinates: equatorial FK5 Equinox: J2000.000 +# Epoch: J2000.00000000 MJD: 51544.50000 + +# Input file: incoords Output file: STDOUT + +13:29:47.297 47:13:37.52 13:29:47.285 47:13:37.93 +13:29:37.406 47:09:09.18 13:29:37.428 47:09:09.17 +13:29:38.700 47:13:36.23 13:29:38.698 47:13:35.99 +13:29:55.424 47:10:05.15 13:29:55.395 47:10:05.04 +13:30:01.816 47:12:58.79 13:30:01.839 47:12:58.72 +.fi + +Note that there are minor differences between the results of examples 1 +and 2 due to precision differences in the input. Note also the difference +in the way the xrotation and yrotation angles are defined between examples +1 and 2. In example 2 the rotations are defined as coordinate rotations, +whereas in example one they are described as axis rotations. + +.ih +BUGS + +.ih +SEE ALSO +ccmap, cctran, skyctran, imctran +.endhelp diff --git a/pkg/images/imcoords/doc/ccstd.hlp b/pkg/images/imcoords/doc/ccstd.hlp new file mode 100644 index 00000000..b24def49 --- /dev/null +++ b/pkg/images/imcoords/doc/ccstd.hlp @@ -0,0 +1,480 @@ +.help ccstd Oct00 images.imcoords +.ih +NAME +ccstd -- transform pixel and celestial coordinates to standard coordinates +and vice versa +.ih +USAGE +ccstd input output database solutions +.ih +PARAMETERS +.ls input +The input coordinate files. Coordinates may be entered by hand by setting input +to "STDIN". +.le +.ls output +The output coordinate files. The number of output files must be one or equal +to the number of input files. Results may be printed on the terminal by +setting output to "STDOUT". +.le +.ls database +The text database file written by the ccmap task which contains the +desired plate solutions. If database is undefined ccstd computes the +standard coordinates or pixel and celestial coordinates using the current +values of the xref, yref, xmag ymag, xrotation, yrotation, lngref, latref, +and projection parameters. +.le +.ls solutions +The database record containing the desired plate solution. +The number of records must be one or equal to the number of input coordinate +files. Solutions is either the user name supplied to ccmap, the name of the +image input to ccmap for which the plate solution is valid, or the name of the +coordinate file that the ccmap task used to compute the plate solution. +The quantities stored in solutions always supersede the values of the +parameters xref, yref, xmag, ymag, xrotation, yrotation, lngref, latref, +and projection. +.le +.ls geometry = "geometric" +The type of geometric transformation. The geometry parameter is +only requested if database is defined. The options are: +.ls linear +Transform the pixel coordinates to standard coordinates or vice versa +using the linear part of the plate solution. +only. +.le +.ls geometric +Transform the pixel coordinates to standard coordinates or vice versa +using the full plate solution. +.le +.le +.ls forward = yes +Transform from pixel and celestial coordinates to standard coordinates ? If +forward is "no" then the plate solution is inverted and standard coordinates +are transformed to pixel and celestial coordinates. +.le +.ls polar = no +Convert to and from polar standard coordinates instead of Cartesian standard +coordinates? +.le +.ls xref = INDEF, yref = INDEF +The pixel coordinates of the reference point. If database is undefined +then xref and yref default to 0.0 and 0.0, otherwise these parameters are +ignored. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in arcseconds per pixel. If database is undefined +xmag and ymag default to 1.0 and 1.0 arcseconds per pixel, otherwise these +parameters are ignored. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles in degrees measured counter-clockwise with +respect to the x and y axes. If database is undefined then xrotation and +yrotation are interpreted as the rotation of the coordinates with respect +to the x and y axes and default to 0.0 and 0.0 degrees. For example xrotation +and yrotation values of 30.0 and 30.0 degrees will rotate a point 30 degrees +counter-clockwise with respect to the x and y axes. To flip the x axis +coordinates in this case either set the angles to 210.0 and 30.0 degrees +or leave the angles at 30.0 and 30.0 and set the xmag parameter to a negative +value. If database is defined these parameters are ignored. The ccmap task +computes the x and y rotation angles of the x and y axes, not the rotation +angle of the coordinates. An celestial coordinate system rotated 30 degrees +counter-clockwise with respect to the pixel coordinate system will produce +xrotation and yrotation values o 330.0 and 330.0 or equivalently -30.0 and +-30.0 degrees in the database file not 30.0 and 30.0. +.le +.ls lngref = INDEF, latref = INDEF +The celestial coordinates of the reference point, e.g. the ra and dec +of the reference point for equatorial systems, galactic longitude and +latitude of the reference for galactic systems. If database is undefined +lngref and latref default to 0.0 and 0.0, otherwise these parameters are +ignored. +.le +.ls lngunits = "", latunits = "" +The units of the input or output ra / longitude and dec / latitude coordinates. +The options are "hours", "degrees", "radians" for ra / longitude coordinates, +and "degrees" and "radians" for dec / latitude systems. If lngunits and +latunits are undefined they default to the values in the database records. +If database is undefined then lngunits and latunits default to "hours" and +"degrees" respectively. +.le +.ls projection = "tan" +The sky projection geometry. The options are "tan", "sin", "arc" and +"lin". If database is undefined then the value of the projection parameter +is used, otherwise this parameter is ignored. +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate file containing the x and y coordinates +if the \fIforward\fR parameter is "yes", or the corresponding standard +coordinates xi and eta if the forward parameter is "no". +.le +.ls lngcolumn = 3, latcolumn = 4 +The columns in the input coordinate file containing the celestial coordinates +if the \fIforward\fR parameter is "yes", or the corresponding standard +coordinates xi and eta if the forward parameter is "no". +.le +.ls lngformat = "", latformat = "" +The default output format of the transformed coordinates in lngcolumn and +latcolumn. If forward = yes then the default output format is "%10.3f". +Otherwise the defaults are "%12.2h" for output coordinates in hours, "%11.1h" +for output coordinates in degrees, and "%13.7g" for output coordinates in +radians. +.le +.ls xformat = "", yformat = "" +The default output format of the transformed coordinates in xcolumn and +ycolumn. The default is "%10.3f". +.le +.ls min_sigdigits = 7 +The minimum precision of the output coordinates. +.le + +.ih +DESCRIPTION + +CCSTD transforms the list of input coordinates in the +text file \fIinput\fR and writes the transformed +coordinates to the text file \fIoutput\fR. The input coordinates +are read from and the output coordinates written to, the columns +\fIxcolumn\fR, \fIycolumn\fR, \fIlngcolumn\fR, and \fIlatcolumn\fR +in the input and output +files. The format of the output coordinates can be specified using the +\fIxformat\fR, \fIyformat\fR, \fIlngformat\fR and \fIlatformat\fR parameters. +If the output formats are unspecified the coordinates are written out with +reasonable default formats, e.g. "%10.3f" for standard coordinates, +"%12.2h" and "11.1h" for celestial coordinates in hours or degrees, +and "%13.7g" for celestial coordinates in radians. All the remaining +fields in the +input file are copied to the output file without modification. Blank lines +and comment lines are also passed to the output file unaltered. + +The plate solution can either be read from record \fIsolutions\fR +in the database file \fIdatabase\fR written by CCMAP, or specified +by the user via the \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, +\fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +and \fIprojection\fR parameters. \fIlngunits\fR and \fIlatunits\fR +define the units of the input celestial coordinates. If +undefined they default to the values in the database or to +the quantities "hours" and "degrees" respectively. The standard coordinates +are always written and read in units of arcseconds. + +If the \fIforward\fR +parameter is "yes", the input coordinates are assumed to be pixel coordinates +and celestial coordinates. The pixel coordinates are transformed to standard +coordinates using the plate solution, and celestial coordinates are +transformed to standard coordinates using the position of the reference +point \fIlngref\fR, \fIlatref\fR, and the projection specified by +\fIprojection\fR. If \fIforward\fR is "no", then +the input coordinates are assumed to be standard coordinates and +those in \fIxcolumn\fR and \fIycolumn\fR are transformed to pixel +coordinates by inverting the plate solution, and those in \fIlngcolumn\fR +and \fIlatcolumn\fR are transformed to celestial coordinates using the +position of the reference point and the specified projection. + +The plate solution computed by CCMAP has the following form where x and y +are the pixel coordinates and xi and eta are the corresponding fitted standard +coordinates in arcseconds per pixel. The observed standard coordinates are +computed by applying the appropriate sky projection to the celestial +coordinates. + + +.nf + xi = f (x, y) + eta = g (x, y) +.fi + +The functions f and g are either power series, Legendre, or Chebyshev +polynomials whose order and region of validity were set by the user when +CCMAP was run. The plate solution is arbitrary and does not correspond to +any physically meaningful model. However the first order terms can be given +the simple geometrical interpretation shown below. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +xref, yref, xi0, and eta0 are the origins of the reference and output +coordinate systems respectively. xi0 and eta0 are both 0.0 by default. +xmag and ymag are the x and y scales in " / pixel, and xrotation and yrotation +are the x and y axes rotation angles measured counter-clockwise from original +x and y axes. + +If the CCMAP database is undefined then CCSTD computes a linear plate +solution using the parameters \fIxref\fR, \fIyref\fR, \fIxmag\fR, +\fIymag\fR, \fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +\fIlngunits\fR, \fIlatunits\fR and \fIprojection\fR as shown below. Note +that in this case xrotation and yrotation are interpreted as the rotation +of the coordinates not the rotation of the coordinate axes. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +Linear plate solutions are evaluated in the forward and reverse sense +using the appropriate IRAF mwcs system routines. Higher order plate +solutions are evaluated in the forward sense using straight-forward +evaluation of the polynomial terms, in the reverse sense by applying +Newton's method to the plate solution. + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +EXAMPLES + +.nf +1. Compute the standard coordinates in arcseconds per pixel given a list of +pixel and equatorial coordinates and the position of the reference point in +pixel and equatorial coordinates. + +cl> type coords +13:29:47.297 47:13:37.52 327.50 410.38 +13:29:37.406 47:09:09.18 465.50 62.10 +13:29:38.700 47:13:36.23 442.01 409.65 +13:29:55.424 47:10:05.15 224.35 131.20 +13:30:01.816 47:12:58.79 134.37 356.33 + +cl> ccstd coords STDOUT "" xref=256.5 yref=256.5 lngref=13:29:48.1 \ +latref = 47:11:53.4 xcol=3 ycol=4 lngcol=1 latcol=2 + -8.180 104.120 71.000 153.880 +-109.087 -164.189 209.000 -194.400 + -95.753 102.854 185.510 153.150 + 74.688 -108.235 -32.150 -125.300 + 139.745 65.441 -122.130 99.830 + +2. Repeat the previous example but output the results in polar coordinates. +The first and third columns contain the radius coordinate in arcseconds, +the second and fourth columns contain the position angle in degrees measured +counter-clockwise with respect to the standard coordinates. + +cl> ccstd coords STDOUT "" xref=256.5 yref=256.5 lngref=13:29:48.1 \ +latref = 47:11:53.4 xcol=3 ycol=4 lngcol=1 latcol=2 polar+ +104.441 94.492 169.470 65.231 +197.124 236.400 285.434 317.073 +140.526 132.952 240.560 39.542 +131.504 304.608 129.359 255.609 +154.309 25.093 157.740 140.737 + + +3. Compute the plate solution and use it to evaluate the Cartesian and +polar standard coordinates for the input coordinate list used in example 1. + +cl> ccmap coords coords.db xcol=3 ycol=4 lngcol=1 latcol=2 inter- +Coords File: coords Image: + Database: coords.db Record: coords +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Coordinate mapping status + Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:48.129 47:11:53.37 (hours degrees) + Reference point: 318.735 273.900 (pixels pixels) + X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 179.110 358.958 (degrees degrees) + + +cl> type coords.db +# Mon 10:29:13 24-Nov-97 +begin coords + xrefmean 318.7460000000001 + yrefmean 273.9320000000001 + lngmean 13.49670238888889 + latmean 47.19815944444444 + coosystem j2000 + projection tan + lngref 13.49670238888889 + latref 47.19815944444444 + lngunits hours + latunits degrees + xpixref 318.7352667484295 + ypixref 273.9002619912411 + geometry general + function polynomial + xishift 247.3577084680361 + etashift -206.1795977453246 + xmag 0.7641733802338992 + ymag 0.7666917500560622 + xrotation 179.1101291109185 + yrotation 358.9582148846163 + wcsxirms 0.2288984454992771 + wcsetarms 0.2411034140453112 + xirms 0.2288984454992771 + etarms 0.2411034140453112 + surface1 11 + 3. 3. + 2. 2. + 2. 2. + 0. 0. + 134.3700000000001 134.3700000000001 + 465.5000000000002 465.5000000000002 + 62.1 62.1 + 410.3800000000001 410.3800000000001 + 247.3577084680361 -206.1795977453246 + -0.7640812161068504 -0.011868034832272 + -0.01393966623835092 0.7665650170136847 + surface2 0 + + +cl> ccstd coords STDOUT coords.db coords xcol=3 ycol=4 lngcol=1 latcol=2 + -8.471 104.146 -8.599 104.517 +-109.378 -164.163 -109.188 -164.100 + -96.044 102.880 -96.084 102.598 + 74.397 -108.210 74.107 -108.269 + 139.454 65.467 139.721 65.376 + +cl> ccstd coords STDOUT coords.db coords xcol=3 ycol=4 lngcol=1 latcol=2 \ +polar+ +104.490 94.650 104.870 94.704 +197.264 236.325 197.106 236.361 +140.744 133.032 140.565 133.122 +131.317 304.509 131.202 304.391 +154.056 25.148 154.259 25.075 + +4. Use the previous plate solution to transform the pixel and equatorial +coordinates to standard coordinates but enter the plate solution by hand. + +cl> ccstd coords STDOUT "" xref=318.735 yref=273.900 lngref=13:29:48.129 \ +latref=47:11:53.37 xmag=.764 ymag=.767 xrot=180.890 yrot=1.042 xcol=3 \ +ycol=4 lngcol=1 latcol=2 + -8.475 104.150 -8.599 104.559 +-109.382 -164.159 -109.161 -164.165 + -96.048 102.884 -96.064 102.640 + 74.393 -108.206 74.092 -108.313 + 139.450 65.471 139.688 65.401 + +cl> ccstd coords STDOUT "" xref=318.735 yref=273.900 lngref=13:29:48.129 \ +latref=47:11:53.37 xmag=.764 ymag=.767 xrot=180.890 yrot=1.042 xcol=3 \ +ycol=4 lngcol=1 latcol=2 polar+ +104.494 94.652 104.912 94.702 +197.263 236.324 197.145 236.378 +140.750 133.032 140.582 133.105 +131.311 304.509 131.230 304.374 +154.054 25.150 154.240 25.089 + +Note that there are minor differences between the results of examples 3 and +4 due to precision differences in the input, and that the angles input +to ccstd in example 4 are the coordinate rotation angles not the axes +rotation angles as printed by ccmap. The difference is exactly 180 degrees +in both cases. + +5. Use the plate solution computed in example 3 to convert a list +of standard coordinates into the equivalent pixel and celestial coordinates. + +cl> type stdcoords + -8.471 104.146 -8.599 104.517 +-109.378 -164.163 -109.188 -164.100 + -96.044 102.880 -96.084 102.598 + 74.397 -108.210 74.107 -108.269 + 139.454 65.467 139.721 65.376 + +cl> ccstd stdcoords STDOUT coords.db coords xcol=3 ycol=4 lngcol=1 latcol=2 \ +forward- + +13:29:47.30 47:13:37.5 327.499 410.381 +13:29:37.41 47:09:09.2 465.500 62.101 +13:29:38.70 47:13:36.2 442.010 409.650 +13:29:55.42 47:10:05.1 224.350 131.200 +13:30:01.82 47:12:58.8 134.370 356.330 +.fi + +.ih +BUGS + +.ih +SEE ALSO +ccmap, ccsetwcs, cctran, finder.tastrom, skyctran +.endhelp diff --git a/pkg/images/imcoords/doc/cctran.hlp b/pkg/images/imcoords/doc/cctran.hlp new file mode 100644 index 00000000..202598f6 --- /dev/null +++ b/pkg/images/imcoords/doc/cctran.hlp @@ -0,0 +1,412 @@ +.help cctran Dec96 images.imcoords +.ih +NAME +cctran -- transform from pixel to celestial coordinates and vice versa +using the computed plate solution +.ih +USAGE +cctran input output database solutions +.ih +PARAMETERS +.ls input +The coordinate files to be transformed. +.le +.ls output +The output coordinate files. The number of output files must +be one or equal to the number of input files. +.le +.ls database +The text database file written by the ccmap task containing the +desired plate solution. If database is undefined cctran computes +a linear plate solution using the current values of the xref, yref, xmag +ymag, xrotation, yrotation, lngref, latref, and projection parameters. +.le +.ls solutions +The database record containing the desired plate solution. +The number of records must be one or equal to the number of input coordinate +files. Solutions is either a user name supplied to ccmap, the name of the +ccmap task +input image for which the plate solution is valid, or the name of the +coordinate file that the ccmap task used to compute the plate solution. +The quantities stored in +solutions always supersede the values of xref, yref, xmag, ymag, +xrotation, yrotation, lngref, latref, and projection. +.le +.ls geometry = "geometric" +The type of geometric transformation. The geometry parameter is +only requested if database is defined. The options are: +.ls linear +Transform the coordinates using only the linear part of the plate solution. +.le +.ls geometric +Transform the coordinates using the full plate solution. +.le +.le +.ls forward = yes +Transform from pixel to celestial coordinates ? If forward is "no" then +the plate solution is inverted and celestial coordinates are transformed +to pixel coordinates. +.le +.ls xref = INDEF, yref = INDEF +The x and y pixel coordinates of the reference point. If database is undefined +then xref and yref default to 0.0 and 0.0, otherwise these parameters are +ignored. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in arcseconds per pixel. If database is undefined +xmag and ymag default to 1.0 and 1.0 arcseconds per pixel, otherwise these +parameters are ignored. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles in degrees measured counter-clockwise with +respect to the x and y axes. Xrotation and yrotation are interpreted as the +rotation of the coordinates with respect to the x and y axes and default to +0.0 and 0.0 degrees. For example xrotation and yrotation values of 30.0 and +30.0 degrees will rotate a point 30 degrees counter-clockwise with respect to +the x and y axes. To flip the x axis coordinates in this case either set the +angles to 210.0 and 30.0 degrees or leave the angles at 30.0 and 30.0 and set +the xmag parameter to a negative value. To set east to the up, down, left, and +right directions, set xrotation to 90, 270, 180, and 0 respectively. To set +north to the up, down, left, and right directions, set yrotation to 0, 180, +90, and 270 degrees respectively. Any global rotation must be added to both the +xrotation and yrotation values. +.le +.ls lngref = INDEF, latref = INDEF +The celestial coordinates of the reference point, e.g. the ra and dec +of the reference point for equatorial systems, galactic longitude and +latitude for galactic systems. If database is undefined +lngref and latred default to 0.0 and 0.0, otherwise these parameters are +ignored. +.le +.ls lngunits = "", latunits = "" +The units of the input or output ra / longitude and dec / latitude coordinates. +The options are "hours", "degrees", "radians" for ra / longitude coordinates, +and "degrees" and "radians" for dec / latitude systems. If lngunits and +latunits are undefined they default to the values in the database records. +If database is undefined then lngunits and latunits default to "hours" and +"degrees" respectively. +.le +.ls projection = "tan" +The sky projection geometry. The most commonly used projections in +astronomy are "tan", "arc", "sin", and "lin". Other supported projections +are "ait", "car", "csc", "gls", "mer", "mol", "par", "pco", "qsc", "stg", +"tsc", and "zea". +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate file containing the x and y coordinates +if the \fIforward\fR parameter is "yes", the celestial ra / longitude and +dec / latitude if the forward parameter is "no". +.le +.ls lngformat = "", latformat = "" +The format of the output coordinates. The defaults are "%10.3f" for +output coordinates in pixels, "%12.2h" for coordinates in hours, +"%11.1h" for coordinates in degrees, +and "%13.7g" for coordinates in radians. +.le +.ls min_sigdigits = 7 +The minimum precision of the output coordinates. +.le + +.ih +DESCRIPTION + +CCTRAN applies the plate solution to a list of pixel or celestial +coordinates in the text file \fIinput\fR and writes the transformed +coordinates to the text file \fIoutput\fR. The input coordinates +are read from and the output coordinates written to, the columns +\fIxcolumn\fR and \fIycolumn\fR in the input and output +files. The format of the output coordinates can be specified using the +\fIlngformat\fR and \fIlatformat\fR parameters. If the output formats +are unspecified the coordinates are written out with reasonable +default precisions, e.g. "%10.3f" for pixel coordinates, "%12.2h" and "11.1h" +for coordinates in hours or degrees, +and "%13.7g" for coordinates in radians. All the remaining fields in the +input file are copied to the output file without modification. Blank lines +and comment lines are also passed to the output file unaltered. + +The plate solution is either read from record \fIsolutions\fR +in the database file \fIdatabase\fR written by CCMAP, or specified +by the user via the \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, +\fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +and \fIprojection\fR parameters. If \fILngunits\fR and \fIlatunits\fR +are undefined they default to the values in the database or to +the quantities "hours" and "degrees" respectively. +If the \fIforward\fR +parameter is "yes", the input coordinates are assumed to be pixel coordinates +and are transformed to celestial coordinates. If \fIforward\fR is "no", then +the input coordinates are assumed to be celestial coordinates and are +transformed to pixel coordinates. + +The transformation computed by CCMAP has the following form where x and y +are the pixel coordinates and xi and eta are the corresponding standard +coordinates in arcseconds per pixel. The standard coordinates are computed +by applying the appropriate sky projection to the celestial coordinates. + + +.nf + xi = f (x, y) + eta = g (x, y) +.fi + +The functions f and g are either power series, Legendre, or Chebyshev +polynomials whose order and region of validity were set by the user when +CCMAP was run. The plate solution is arbitrary and does not correspond to +any physically meaningful model. However the first order terms can be given +the simple geometrical interpretation shown below. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +xref, yref, xi0, and eta0 are the origins of the reference and output +coordinate systems respectively. xi0 and eta0 are both 0.0 by default. +xmag and ymag are the x and y scales in " / pixel, and xrotation and yrotation +are the x and y axes rotation angles measured counter-clockwise from original +x and y axes. + +If the CCMAP database is undefined then CCTRAN computes a linear plate +solution using the parameters \fIxref\fR, \fIyref\fR, \fIxmag\fR, +\fIymag\fR, \fIxrotation\fR, \fIyrotation\fR, \fIlngref\fR, \fIlatref\fR, +\fIlngunits\fR, \fIlatunits\fR and \fIprojection\fR as shown below. Note +that in this case xrotation and yrotation are interpreted as the rotation +of the coordinates not the rotation of the coordinate axes. + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xi0 - b * xref - c * yref = xshift + d = eta0 - e * xref - f * yref = yshift + xi0 = 0.0 + eta0 = 0.0 +.fi + +Linear plate solutions are evaluated in the forward and reverse sense +using the appropriate IRAF mwcs system routines. Higher order plate +solutions are evaluated in the forward sense using straight-forward +evaluation of the polynomial terms, in the reverse sense by applying +Newton's method to the plate solution. + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +EXAMPLES + +1. Compute the plate solution and evaluate the forward transformation for +the following input coordinate list. + +.nf +cl> type coords +13:29:47.297 47:13:37.52 327.50 410.38 +13:29:37.406 47:09:09.18 465.50 62.10 +13:29:38.700 47:13:36.23 442.01 409.65 +13:29:55.424 47:10:05.15 224.35 131.20 +13:30:01.816 47:12:58.79 134.37 356.33 + + +cl> ccmap coords coords.db xcol=3 ycol=4 lngcol=1 latcol=2 inter- +Coords File: coords Image: + Database: coords.db Record: coords +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 +Coordinate mapping status + Ra/Dec or Long/Lat fit rms: 0.229 0.241 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:48.129 47:11:53.37 (hours degrees) + Reference point: 318.735 273.900 (pixels pixels) + X and Y scale: 0.764 0.767 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 179.110 358.958 (degrees degrees) + + +cl> type coords.db +# Mon 15:10:37 13-May-96 +begin coords + xrefmean 318.7460000000001 + yrefmean 273.9320000000001 + lngmean 13.49670238888889 + latmean 47.19815944444444 + coosystem j2000 + projection tan + lngref 13.49670238888889 + latref 47.19815944444444 + lngunits hours + latunits degrees + xpixref 318.7352667484295 + ypixref 273.9002619912411 + geometry general + function polynomial + xishift 247.3577084680361 + etashift -206.1795977453246 + xmag 0.7641733802338992 + ymag 0.7666917500560622 + xrotation 179.1101291109185 + yrotation 358.9582148846163 + wcsxirms 0.2288984454992771 + wcsetarms 0.2411034140453112 + xirms 0.2288984454992771 + etarms 0.2411034140453112 + surface1 11 + 3. 3. + 2. 2. + 2. 2. + 0. 0. + 134.3700000000001 134.3700000000001 + 465.5000000000002 465.5000000000002 + 62.1 62.1 + 410.3800000000001 410.3800000000001 + 247.3577084680361 -206.1795977453246 + -0.7640812161068504 -0.011868034832272 + -0.01393966623835092 0.7665650170136847 + surface2 0 + + + +cl> cctran coords STDOUT coords.db coords xcol=3 ycol=4 lngformat=%0.3h \ +latformat=%0.2h +13:29:47.297 47:13:37.52 13:29:47.284 47:13:37.89 +13:29:37.406 47:09:09.18 13:29:37.425 47:09:09.24 +13:29:38.700 47:13:36.23 13:29:38.696 47:13:35.95 +13:29:55.424 47:10:05.15 13:29:55.396 47:10:05.09 +13:30:01.816 47:12:58.79 13:30:01.842 47:12:58.70 + +cl> cctran coords STDOUT coords.db coords xcol=1 ycol=2 forward- +327.341 409.894 327.50 410.38 +465.751 62.023 465.50 62.10 +441.951 410.017 442.01 409.65 +223.970 131.272 224.35 131.20 +134.717 356.454 134.37 356.33 +.fi + +Note that for the forward transformation the original ras and decs are in +columns 1 and 2 and the computed ras and decs are in columns 3 and 4, but +for the reverse transformation the original x and y values are in columns +3 and 4 and the computed values are in columns 1 and 2. + + +2. Use the previous plate solution to transform x and y values to +ra and dec values and vice versa but enter the plate solution by hand. + +.nf +cl> cctran coords STDOUT "" xcol=3 ycol=4 lngformat=%0.3h latformat=%0.2h \ +xref=318.735 yref=273.900 lngref=13:29:48.129 latref=47:11:53.37 \ +xmag=.764 ymag=.767 xrot=180.890 yrot=1.042 +13:29:47.297 47:13:37.52 13:29:47.285 47:13:37.93 +13:29:37.406 47:09:09.18 13:29:37.428 47:09:09.17 +13:29:38.700 47:13:36.23 13:29:38.698 47:13:35.99 +13:29:55.424 47:10:05.15 13:29:55.395 47:10:05.04 +13:30:01.816 47:12:58.79 13:30:01.839 47:12:58.72 + +cl> cctran coords STDOUT "" xcol=1 ycol=2 xref=318.735 yref=273.900 \ +lngref=13:29:48.129 latref=47:11:53.37 xmag=.764 ymag=.767 \ +xrot=180.890 yrot=1.042 forward- +327.347 409.845 327.50 410.38 +465.790 62.113 465.50 62.10 +441.983 409.968 442.01 409.65 +223.954 131.334 224.35 131.20 +134.680 356.426 134.37 356.33 + +.fi + +Note that there are minor differences between examples 1 and 2 due to +precision differences in the input, and that the angles input to cctran +in example 2 are the coordinate rotation angles not the axes rotation angles +as printed by ccmap. The different is exactly 180 degrees in both cases. + +.ih +BUGS + +.ih +SEE ALSO +ccmap, ccsetwcs, finder.tastrom, skyctran +.endhelp diff --git a/pkg/images/imcoords/doc/ccxymatch.hlp b/pkg/images/imcoords/doc/ccxymatch.hlp new file mode 100644 index 00000000..6987a437 --- /dev/null +++ b/pkg/images/imcoords/doc/ccxymatch.hlp @@ -0,0 +1,781 @@ +.help ccxymatch Oct96 images.imcoords +.ih +NAME +ccxymatch -- Match celestial and pixel coordinate lists using various methods +.ih +USAGE +ccxymatch input reference output tolerance [ptolerance] +.ih +PARAMETERS +.ls input +The list of input pixel coordinate files. +.le +.ls reference +The list of input celestial coordinate files. The number of celestial coordinate +files must be one or equal to the number of pixel coordinate files. +.le +.ls output +The output matched coordinate files containing: 1) the celestial coordinates +of the matched objects in columns 1 and 2, 2) the pixel coordinates of the +matched objects in columns 3 and 4, and 3) the line numbers of the matched +objects in the celestial coordinate and pixel lists in columns 5 and 6. +.le +.ls tolerance +The matching tolerance in arcseconds. +.le +.ls ptolerance +The matching tolerance in pixels. The ptolerance parameter is required +by the "triangles" matching algorithm but not by the "tolerance" matching +algorithm. +.le +.ls refpoints = "" +A file of tie points used to compute the linear transformation +from the pixel coordinate system to the celestial coordinate system. Refpoints +is a text file containing the celestial coordinates of 1-3 tie points +in the first line, followed by the pixel coordinates of the same 1-3 tie points +in succeeding lines. The celestial coordinates are assumed to be +in the units specified by \fIlngunits\fR and \fIlatunits\fR. +If refpoints is undefined then the parameters \fIxin\fR, \fIyin\fR, +\fIxmag\fR, \fIymag\fR, \fIxrotation\fR, \fIyrotation\fR, \fIprojection\fR, +\fIlngref\fR, and \fIlatref\fR are used to compute the linear transformation. +.le +.ls xin = INDEF, yin = INDEF +The x and y origin of the pixel coordinate system. Xin and yin default to +0.0 and 0.0 respectively. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in arcseconds per pixel. Xmag and +ymag default to 1.0 and 1.0 respectively. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles measured in degrees counter-clockwise. Xrotation +and yrotation default to 0.0 and 0.0 degrees respectively. To set east to the +up, down, left, and right directions, set xrotation to 90, 270, 180, and 0 +respectively. To set north to the up, down, left, and right directions, set +yrotation to 0, 180, 90, and 270 degrees respectively. Any global rotation +must be added to both the xrotation and yrotation values. +.le +.ls projection = "tan" +The sky projection geometry. The most commonly used projections in +astronomy are "tan", "arc", "sin", and "lin". Other supported projections +are "ait", "car", "csc", "gls", "mer", "mol", "par", "pco", "qsc", "stg", +"tsc", and "zea". +.le +.ls lngref = INDEF, latref = INDEF +The origin of the celestial coordinate system. Lngref and latref define the +reference point of the sky projection \fIprojection\fR, and default to the +mean of the ra / longitude and dec / latitude coordinates respectively. Lngref +and latref are assumed to be in units of \fIlngunits\fR and \fIlatunits\fR. +.le +.ls lngcolumn = 1, latcolumn = 2 +The columns in the celestial coordinate list containing the ra / longitude +and dec / latitude coordinate values. +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the pixel coordinate list containing the x and y coordinate +values. +.le +.ls lngunits = "hours", latunits = "degrees" +The units of the celestial coordinates. The options are "hours", "degrees", +and "radians" for lngunits, and "degrees" and "radians" for latunits. +.le +.ls separation = 3.0 +The minimum separation in arcseconds for objects in the celestial coordinate +lists. Objects closer together than separation arcseconds +are removed from the celestial coordinate lists prior to matching. +.le +.ls pseparation = 9.0 +The minimum separation in pixels for objects in the pixel coordinate +lists. Objects closer together than pseparation pixels +are removed from the pixel coordinate lists prior to matching. +.le +.ls matching = "triangles" +The matching algorithm. The choices are: +.ls tolerance +A linear transformation is applied to the pixel coordinates, +the appropriate projection is applied to the celestial coordinates, +the transformed pixel and celestial coordinates are sorted, +points which are too close together are removed, and the pixel coordinates +which most closely match the celestial coordinates to within the +user specified tolerance are determined. The tolerance algorithm requires +an initial estimate for the linear transformation. This estimate can be +derived by supplying the coordinates of tie points via the +\fIrefpoints\fR file, or by setting the linear transformation parameters +\fIxin\fR, \fIyin\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +\fIyrotation\fR, \fIprojection\fR, \fIlngref\fR, and \fIlatref\fR. Assuming that +a good initial estimate for the required linear transformation is supplied, +the tolerance algorithm functions well in the presence of shifts, axis +flips, x and y scale changes, rotations, and axis skew between the two +coordinate systems. The algorithm is sensitive to higher order distortion terms +in the coordinate transformation. +.le +.ls triangles +A linear transformation is applied to the pixel coordinates, +the appropriate projection is applied to the celestial coordinates, +the transformed pixel and celestial coordinates are sorted, points +which are too close together are removed, and the pixel coordinates +are matched to the celestial coordinates using a triangle pattern +matching algorithm and user specified tolerance parameters. +The triangles pattern matching algorithm does not require prior knowledge +of the linear transformation, although it will use a transformation if one +is supplied. The algorithm functions well in the presence of +shifts, axis flips, magnification, and rotation between the two coordinate +systems, as long as both lists have a reasonable number of objects +in common and the errors in the computed coordinates are small. +However as the algorithm depends on comparisons of similar triangles, it +is sensitive to differences in the x and y coordinate scales, +skew between the x and y axes, and higher order distortion terms +in the coordinate transformation. +.le +.le +.ls nmatch = 30 +The maximum number of celestial and pixel coordinates used +by the "triangles" pattern matching algorithm. If either list contains +more coordinates than nmatch, the lists are subsampled. Nmatch should be +kept small as the computation and memory requirements of the "triangles" +algorithm depend on a high power of the lengths of the respective lists. +.le +.ls ratio = 10.0 +The maximum ratio of the longest to shortest side of the +triangles generated by the "triangles" pattern matching algorithm. +Triangles with computed longest to shortest side ratios > ratio +are rejected from the pattern matching algorithm. Ratio should never +be set higher than 10.0 but may be set as low as 5.0. +.le +.ls nreject = 10 +The maximum number of rejection iterations for the "triangles" pattern +matching algorithm. +.le +.ls lngformat = "", latformat = "" +The format of the output celestial coordinates. The default formats are +"%13.3h", "%13.3h", and "%13.7g" for units of "hours", "degrees", and +"radians" respectively. +.le +.ls xformat = "%13.3f", yformat = "%13.3f" +The format of the output pixel coordinates. +By default the coordinates are output right justified in a field of +13 characters with 3 places following the decimal point. +.le +.ls verbose = yes +Print messages about the progress of the task ? +.le + +.ih +DESCRIPTION + +CCXYMATCH matches ra / dec or longitude / latitude coordinates in the +celestial coordinate list \fIreference\fR to their corresponding x and y +coordinates in the pixel coordinate list \fIinput\fR using user specified +tolerances in arcseconds \fItolerance\fR and pixels \fIptolerance\fR, and +writes the matched coordinates to the output file \fIoutput\fR. The output +file is suitable for input to the plate solution computation task CCMAP. + +CCXYMATCH matches the coordinate lists by: 1) projecting the celestial +coordinates onto a plane using the sky projection geometry \fIprojection\fR +and the reference point \fIlngref\fR and \fIlatref\fR, +2) computing an initial guess for the linear transformation required to +match the pixel coordinate system to the projected celestial coordinate system, +3) applying the computed transformation to the pixel coordinates, 4) sorting +the projected celestial and pixel coordinates lists, 5) removing points with a +minimum separation specified by the parameters \fIseparation\fR and +\fIpseparation\fR from both lists, 6) matching the two lists using either +the "triangles" or "tolerance" matching algorithms, and 7) writing the matched +list to the output file. + +An initial estimate for the linear transformation is computed in one of +two ways. If \fIrefpoints\fR is defined, the celestial and pixel coordinates +of up to three tie points are read from succeeding lines in the refpoints file, +and used to compute the linear transformation. The coordinates of the tie +points can be typed in by hand if \fIrefpoints\fR is "STDIN". The formats of +two sample refpoints files are shown below. + +.nf +# First sample refpoints file (1 reference file and N input files) + +ra1 dec1 [ra2 dec2 [ra3 dec3]] # tie points for reference coordinate file + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file 1 + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file 2 +.. .. [ .. .. [ .. ..] + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file N + + +# Second sample refpoints file (N reference files and N input files) + +ra1 dec1 [ra2 dec2 [ra3 dec3]] # tie points for reference coordinate file 1 + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file 1 +ra1 dec1 [ra2 dec2 [ra3 dec3]] # tie points for reference coordinate file 2 + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file 2 + .. .. [ .. .. [ .. ..]] +ra1 dec1 [ra2 dec2 [ra3 dec3]] # tie points for reference coordinate file N + x1 y1 [ x2 y2 [ x3 y3]] # tie points for input coordinate file N + +.fi + +If the refpoints file is undefined the parameters \fIxin\fR, \fIxin\fR, +\fIxmag\fR, \fIymag\fR, \fIxrotation\fR, \fIxrotation\fR are used +to compute a linear transformation from the pixel coordinates to the +standard coordinates xi and eta as shown below. Orientation and skew +are the orientation of the x and y axes and their deviation from +perpendicularity respectively. + + +.nf + xi = a + b * x + c * y + eta = d + e * x + f * y + + xrotation = orientation - skew / 2 + yrotation = orientation + skew / 2 + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = 0.0 - b * xin - c * yin = xshift + d = 0.0 - e * xin - f * yin = yshift +.fi + +Both methods of computing the initial linear transformation compute the +standard coordinates xi and eta by projecting the celestial coordinates +onto a plane using the sky projection geometry \fIprojection\fR and the +reference point \fIlngref\fR and \fIlatref\fR. The celestial coordinates +are assumed to be in units of \fIlngunits\fR and \fIlatunits\fR and the +standard coordinates are in arcseconds. The linear transformation and its +geometric interpretation are shown below. + +The celestial and pixel coordinates are read from columns \fIlngcolumn\fR and +\fIlatcolumn\fR in the celestial coordinate list, and \fIxcolumn\fR, and +\fIycolumn\fR in the pixel coordinate list respectively. The pixel +coordinates are transformed using the linear transformation described above, +the celestial coordinate in units of \fIlngunits\fR and \fIlatunits\fR +are projected to standard coordinates in arcseconds, and stars closer together +than \fIseparation\fR arcseconds and \fIpseparation\fR pixels are removed +from the celestial and pixel coordinate lists respectively. + +The coordinate lists are matched using the matching algorithm specified by +\fImatching\fR. If matching is "tolerance", CCXYMATCH searches the transformed +sorted pixel coordinate list for the coordinates that are within the matching +tolerance \fItolerance\fR and closest to the current standard coordinates. +The major advantage of the "tolerance" algorithm is that it can handle x and y +scale differences and axis skew in the coordinate transformation. The major +disadvantage of the "tolerance" algorithm is that the user must supply +tie point information in all but the simplest case of small x and y +shifts between the pixel and celestial coordinate systems. + +If matching is "triangles", CCXYMATCH constructs a list of triangles +using up to \fInmatch\fR celestial coordinates and transformed pixel +coordinates and performs a pattern matching operation on the resulting +triangle lists. If the number of coordinates in both lists is less than +\fInmatch\fR the entire list is matched using the "triangles" algorithm +directly, otherwise the "triangles" algorithm is used to estimate a new +linear transformation, the input coordinate list is transformed using +the new transformation, and the entire list is matched using the "tolerance" +algorithm. The major advantage of the "triangles" algorithm is that it +requires no tie point information from the user. The major disadvantages of the +algorithm are that, it is sensitive to x and y scale differences and axis +skew between the celestial and pixel coordinate systems, and can be +computationally expensive. + +The matched celestial and pixel coordinates are written to columns 1, 2, 3, +and 4 of the output file, in the formats specified by the \fIlngformat\fR, +\fIlatformat\fR, \fIxformat\fR and \fIyformat\fR parameters. The original +line numbers in the celestial and pixels coordinate files are written to +columns 5 and 6. + +If \fIverbose\fR is yes, detailed messages about actions taken by the +task are written to the terminal as the task executes. + +.ih +ALGORITHMS + +The "triangles" algorithm uses a sophisticated pattern matching +technique which requires no tie point information from the user. +It is expensive computationally and is therefore restricted to a maximum +of \fInmatch\fR objects from the celestial and pixel coordinate lists. + +The "triangles" algorithm first generates a list +of all the possible triangles that can be formed from the points in each list. +For a list of nmatch points this number is the combinatorial factor +nmatch! / [(nmatch-3)! * 3!] or nmatch * (nmatch-1) * (nmatch-2) / 6. +The length of the perimeter, ratio of longest to shortest side, cosine +of the angle between the longest and shortest side, the tolerances in +the latter two quantities and the direction of the arrangement of the vertices +of each triangle are computed and stored in a table. +Triangles with vertices closer together than \fItolerance\fR and +\fIptolerance\fR, or +with a ratio of the longest to shortest side greater than \fIratio\fR +are discarded. The remaining triangles are sorted in order of increasing +ratio. A sort merge algorithm is used to match the triangles using the +ratio and cosine information, the tolerances in these quantities, and +the maximum tolerances for both lists. The ratios of the +perimeters of the matched triangles are compared to the most common ratio +for the entire list, and triangles which deviate too widely from this number +are discarded. The number of triangles remaining are divided into +the number which match in the clockwise sense and the number which match +int the counter-clockwise sense. Those in the minority category +are eliminated. +The rejection step can be repeated up to \fInreject\fR times or until +no more rejections occur, whichever comes first. +The last step in the algorithm is a voting procedure in which each remaining +matched triangle casts three votes, one for each matched pair of vertices. +Points which have fewer than half the maximum number of +votes are discarded. The final set of matches are written to the output file. + +The "triangles" algorithm functions well when the celestial and +pixel coordinate lists have a sufficient number of objects (50%, +in some cases as low as 25%) of their objects in common, any distortions +including x and y scale differences and skew between the two systems are small, +and the random errors in the coordinates are small. Increasing the value of +the \fItolerance\fR parameter will increase the ability to deal with +distortions but will also produce more false matches which after some point +will swamp the true matches. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +A detailed description of the "triangles" pattern matching algorithm used here +can be found in the article "A Pattern-Matching Algorithm for Two- +Dimensional Coordinate Lists" by E.J. Groth, A.J. 91, 1244 (1986). + +.ih +EXAMPLES + +1. Compute the plate solution for a 1528 by 2288 B band image of M51 by +matching a list of reference stars extracted from the Guide Star Catalog +with the regions task against a list of bright stars detected with the daofind +task. The approximate image center is RA = 13:29:52.8 and DEC = +47:11:41 +(J2000) and the image scale is 0.43 arcseconds / pixel. + +.nf +... Get the guide stars (see stsdas.analysis.gasp package). +cl> regions 13:29:52.8 47:11:41 0.27 m51b.gsc.tab + +... Convert the binary table to a text file (see package tables.ttools). +cl> tprint m51b.gsc.tab > m51b.gsc + +... Examine the guide star list. +cl> type m51b.gsc + +# Table m51b.gsc.tab Tue 10:39:55 22-Oct-96 + +# row RA_HRS RA_DEG DEC_DEG MAG +# hours degrees degrees magnitudes + + 1 13:29:13.33 202:18:19.9 47:14:16.3 12.3 + 2 13:29:05.51 202:16:22.6 47:10:44.7 14.8 + 3 13:29:48.60 202:27:09.0 47:07:42.5 15.0 + 4 13:29:47.30 202:26:49.4 47:13:37.5 10.9 + 5 13:29:31.65 202:22:54.7 47:18:54.7 15.0 + 6 13:29:06.16 202:16:32.4 47:04:53.1 14.9 + 7 13:29:37.40 202:24:21.1 47:09:09.2 15.1 + 8 13:29:38.70 202:24:40.5 47:13:36.2 15.0 + 9 13:29:55.42 202:28:51.3 47:10:05.2 15.4 + 10 13:29:06.91 202:16:43.7 47:04:07.9 12.4 + 11 13:29:29.73 202:22:25.9 47:12:04.1 15.1 + 12 13:30:07.96 202:31:59.4 47:05:18.3 14.7 + 13 13:30:01.82 202:30:27.2 47:12:58.8 11.8 + 14 13:30:36.75 202:39:11.2 47:04:05.9 14.9 + 15 13:30:34.04 202:38:30.6 47:16:44.8 13.2 + 16 13:30:14.95 202:33:44.3 47:10:27.6 13.4 + +... Locate bright stars in the image (see noao.digiphot.daophot package). +... Suitable values for fwhmpsf, sigma, ... and threshold can be determined +... using the imstatistics and imexamine tasks. Some experimentation may be +... necessary to determine optimal values. +cl> daofind m51b "default" fwhmpsf=4.0 sigma=5.0 threshold=20.0 + +... Examine the star list. +cl> type m51b.coo.1 + + ... +#N XCENTER YCENTER MAG SHARPNESS SROUND GROUND ID + ... + 401.034 147.262 -2.315 0.473 -0.075 -0.170 1 + 261.137 453.696 -1.180 0.481 -0.373 -0.135 2 + 860.002 480.061 -1.397 0.373 -0.218 -0.178 3 + 69.342 675.895 -0.955 0.368 -0.294 -0.133 4 + 1127.791 680.033 -1.166 0.449 -0.515 -0.326 5 + 972.435 691.544 -1.722 0.449 -0.327 -0.060 6 + 1348.891 715.084 -1.069 0.389 -0.242 -0.145 7 + 946.114 797.067 -0.543 0.406 -0.198 -0.069 8 + 698.455 811.407 -1.620 0.437 -0.038 -0.028 9 + 964.566 853.201 -0.317 0.382 0.031 -0.086 10 + 236.088 864.817 -3.515 0.429 -0.164 -0.035 11 + 919.703 909.835 -3.775 0.447 0.051 0.007 12 + 406.592 985.807 -0.715 0.424 -0.307 -0.068 13 + 920.790 986.083 -0.600 0.364 -0.047 0.021 14 + 761.403 1037.795 -1.944 0.383 -0.023 0.120 15 + 692.012 1050.603 -0.508 0.339 -0.365 -0.164 16 + 1023.330 1060.144 -1.897 0.381 -0.246 -0.288 17 + 681.864 1066.937 -0.059 0.467 -0.175 0.135 18 + 1307.802 1085.564 -1.173 0.435 0.032 -0.207 19 + 716.494 1094.800 -0.389 0.421 -0.412 -0.032 20 + 715.935 1106.616 -3.747 0.649 0.271 0.245 21 + 1093.813 1300.189 -1.557 0.377 -0.309 -0.078 22 + 596.406 1353.798 -0.461 0.383 0.029 -0.103 23 + 1212.117 1362.636 -0.362 0.369 -0.180 0.043 24 + 251.355 1488.048 -0.909 0.357 -0.390 0.077 25 + 600.659 1630.261 -1.392 0.423 0.013 -0.312 26 + 329.448 2179.233 -0.824 0.442 -0.463 0.325 27 + +... Match the two lists using the "triangles" algorithm and tolerances of +... 1.0 arcseconds and 3.0 pixels respectively. +cl> ccxymatch m51b.coo.1 m51b.gsc m51b.mat.1 1.0 3.0 lngcolumn=2 latcolumn=4 + +... Examine the matched file. +cl> type m51b.mat.1 + +# Input: m51b.coo.1 Reference: m51b.gsc Number of tie points: 0 +# Initial linear transformation +# xref[tie] = 0. + 1. * x[tie] + 0. * y[tie] +# yref[tie] = 0. + 0. * x[tie] + 1. * y[tie] +# dx: 0.00 dy: 0.00 xmag: 1.000 ymag: 1.000 xrot: 0.0 yrot: 0.0 +# +# Column definitions +# Column 1: Reference Ra / Longitude coordinate +# Column 2: Reference Dec / Latitude coordinate +# Column 3: Input X coordinate +# Column 4: Input Y coordinate +# Column 5: Reference line number +# Column 6: Input line number + + 13:29:48.600 47:07:42.50 860.002 480.061 8 44 + 13:29:38.700 47:13:36.20 1093.813 1300.189 13 63 + 13:29:55.420 47:10:05.20 698.455 811.407 14 50 + 13:29:29.730 47:12:04.10 1307.802 1085.564 16 60 + 13:30:07.960 47:05:18.30 401.034 147.262 17 42 + 13:30:14.950 47:10:27.60 236.088 864.817 21 52 + +... Compute the plate solution. +cl> ccmap m51b.mat.1 ccmap.db results=STDOUT xcolumn=3 ycolumn=4 lngcolumn=1 \ +latcolumn=2 refpoint=user lngref=13:29:52.8 latref=47:11:41 interactive=no + +Coords File: m51b.mat.1 Image: + Database: ccmap.db Record: m51b.mat.1 +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Coordinate mapping status + XI fit ok. ETA fit ok. + Ra/Dec or Long/Lat fit rms: 0.206 0.103 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:52.800 47:11:41.00 (hours degrees) + Reference point: 760.656 1033.450 (pixels pixels) + X and Y scale: 0.430 0.431 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 180.158 359.991 (degrees degrees) + + Input Coordinate Listing + X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec + + 860.0 480.1 13:29:48.60 47:07:42.5 13:29:48.62 47:07:42.5 -0.153 0.017 +1093.8 1300.2 13:29:38.70 47:13:36.2 13:29:38.73 47:13:36.4 -0.258 -0.164 + 698.5 811.4 13:29:55.42 47:10:05.2 13:29:55.43 47:10:05.2 -0.062 0.024 +1307.8 1085.6 13:29:29.73 47:12:04.1 13:29:29.70 47:12:04.0 0.318 0.123 + 401.0 147.3 13:30:07.96 47:05:18.3 13:30:07.96 47:05:18.4 0.028 -0.073 + 236.1 864.8 13:30:14.95 47:10:27.6 13:30:14.94 47:10:27.5 0.127 0.073 +.fi + + + +2. Repeat example 1 but replace the daofind pixel list with one generated +using the center task and a finder chart created with the skymap task. + +.nf +... Get the guide stars. (see stsdas.analysis.gasp package) +cl> regions 13:29:52.8 47:11:41 0.27 m51b.gsc.tab + +... Create the finder chart (see stsdas.analysis.gasp package) +cl> gasp.skymap m51b.gsc.tab 13:29:52.8 47:11:41 INDEF 0.27 \ +objstyle=square racol=RA_HRS deccol=DEC_DEG magcol=MAG interactive- \ +dev=stdplot + +... Convert the binary table to a text file. (see tables.ttools package) +cl> tprint m51b.gsc.tab > m51b.gsc + +... Mark and center the guide stars on the image display using the finder +... chart produced by the skymap task and the center task (see the +... digiphot.apphot package). +cl> display m51b 1 fi+ +cl> center m51b cbox=7.0 ... +cl> pdump m51b.ctr.1 xcenter,ycenter yes > m51b.pix + +... Display the pixel coordinate list. +cl> type m51b.pix + +401.022 147.183 +236.044 864.882 +698.368 811.329 +860.003 480.051 +1127.754 680.020 +1307.819 1085.615 +1093.464 1289.595 +1212.001 1362.594 +1348.963 715.085 + +... Match the two lists using the "triangles" algorithm and tolerances of +... 1.0 arcseconds and 3.0 pixels respectively. +cl> ccxymatch m51b.pix m51b.gsc m51b.mat.2 1.0 3.0 lngcolumn=2 latcolumn=4 + +... Examine the matched file. +cl> type m51b.mat.2 + +# Input: m51b.pix Reference: m51b.gsc Number of tie points: 0 +# Initial linear transformation +# xi[tie] = 0. + 1. * x[tie] + 0. * y[tie] +# eta[tie] = 0. + 0. * x[tie] + 1. * y[tie] +# dx: 0.00 dy: 0.00 xmag: 1.000 ymag: 1.000 xrot: 0.0 yrot: 0.0 +# +# Column definitions +# Column 1: Reference Ra / Longitude coordinate +# Column 2: Reference Dec / Latitude coordinate +# Column 3: Input X coordinate +# Column 4: Input Y coordinate +# Column 5: Reference line number +# Column 6: Input line number + + 13:29:48.600 47:07:42.50 860.003 480.051 8 4 + 13:29:37.400 47:09:09.20 1127.754 680.020 12 5 + 13:29:55.420 47:10:05.20 698.368 811.329 14 3 + 13:29:29.730 47:12:04.10 1307.819 1085.615 16 6 + 13:30:07.960 47:05:18.30 401.022 147.183 17 1 + 13:30:14.950 47:10:27.60 236.044 864.882 21 2 + +... Compute the plate solution. +cl> ccmap m51b.mat.2 ccmap.db results=STDOUT xcolumn=3 ycolumn=4 lngcolumn=1 \ +latcolumn=2 refpoint=user lngref=13:29:52.8 latref=47:11:41 interactive=no + +Coords File: m51b.mat.2 Image: + Database: junk.db Record: m51b.mat.2 +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Coordinate mapping status + XI fit ok. ETA fit ok. + Ra/Dec or Long/Lat fit rms: 0.312 0.0664 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:52.800 47:11:41.00 (hours degrees) + Reference point: 761.093 1033.230 (pixels pixels) + X and Y scale: 0.430 0.431 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 180.175 359.998 (degrees degrees) + + Input Coordinate Listing + X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec +.fi + + +3. Repeat example 1 but use the "tolerance" matching algorithm and apriori +knowledge of the celestial and pixel coordinates of the nucleus of M51, +the x and y image scales, and the orientation of the detector on the telescope +to match the two lists. + +.nf +... Match the two lists using the ccxymatch "tolerance" algorithm and +... a matching tolerance of 2.0 arcseconds. Note the negative and positive +... signs on the xmag and ymag parameters and lack of any rotation, +... indicating that north is up and east is to the left. +cl> ccxymatch m51b.coo.1 m51b.gsc m51b.mat.3 2.0 lngcolumn=2 latcolumn=4 \ +matching=tolerance xin=761.40 yin=1037.80 xmag=-0.43 ymag=0.43 xrot=0.0 \ +yrot=0.0 lngref=13:29:52.80 latref=47:11:42.9 + +... Examine the matched file. +cl> type m51b.mat.3 + +# Input: m51b.coo.1 Reference: m51b.gsc Number of tie points: 0 +# Initial linear transformation +# xref[tie] = 327.402 + -0.43 * x[tie] + 0. * y[tie] +# yref[tie] = -446.254 + 0. * x[tie] + 0.43 * y[tie] +# dx: 327.40 dy: -446.25 xmag: 0.430 ymag: 0.430 xrot: 180.0 yrot: 0.0 +# +# Column definitions +# Column 1: Reference Ra / Longitude coordinate +# Column 2: Reference Dec / Latitude coordinate +# Column 3: Input X coordinate +# Column 4: Input Y coordinate +# Column 5: Reference line number +# Column 6: Input line number + + 13:30:07.960 47:05:18.30 401.034 147.262 17 42 + 13:29:48.600 47:07:42.50 860.002 480.061 8 44 + 13:29:37.400 47:09:09.20 1127.791 680.033 12 46 + 13:29:55.420 47:10:05.20 698.455 811.407 14 50 + 13:30:14.950 47:10:27.60 236.088 864.817 21 52 + 13:29:29.730 47:12:04.10 1307.802 1085.564 16 60 + 13:29:38.700 47:13:36.20 1093.813 1300.189 13 63 + + +... Compute the plate solution. +cl> ccmap m51b.mat.3 ccmap.db results=STDOUT xcolumn=3 ycolumn=4 lngcolumn=1 \ +latcolumn=2 refpoint=user lngref=13:29:52.8 latref=47:11:41 interactive=no + +Coords File: m51b.mat.3 Image: + Database: ccmap.db Record: m51.mat.3 +Refsystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Insystem: j2000 Coordinates: equatorial FK5 + Equinox: J2000.000 Epoch: J2000.000 MJD: 51544.50000 +Coordinate mapping status + XI fit ok. ETA fit ok. + Ra/Dec or Long/Lat fit rms: 0.342 0.121 (arcsec arcsec) +Coordinate mapping parameters + Sky projection geometry: tan + Reference point: 13:29:52.800 47:11:41.00 (hours degrees) + Reference point: 760.687 1033.441 (pixels pixels) + X and Y scale: 0.430 0.431 (arcsec/pixel arcsec/pixel) + X and Y axis rotation: 180.174 359.949 (degrees degrees) + + Input Coordinate Listing + X Y Ra Dec Ra(fit) Dec(fit) Dra Ddec + + 401.0 147.3 13:30:07.96 47:05:18.3 13:30:07.97 47:05:18.4 -0.109 -0.109 + 860.0 480.1 13:29:48.60 47:07:42.5 13:29:48.64 47:07:42.5 -0.385 -0.045 +1127.8 680.0 13:29:37.40 47:09:09.2 13:29:37.34 47:09:09.0 0.572 0.152 + 698.5 811.4 13:29:55.42 47:10:05.2 13:29:55.43 47:10:05.2 -0.118 0.009 + 236.1 864.8 13:30:14.95 47:10:27.6 13:30:14.92 47:10:27.5 0.290 0.116 +1307.8 1085.6 13:29:29.73 47:12:04.1 13:29:29.72 47:12:04.0 0.082 0.060 +1093.8 1300.2 13:29:38.70 47:13:36.2 13:29:38.73 47:13:36.4 -0.332 -0.184 +.fi + + + +4. Repeat example 3 but input the appropriate linear transformation via a list +of tie points, rather than setting the transformation parameters directly. + +.nf +... Display the tie points. +cl> type refpts +13:29:55.42 47:10:05.2 13:29:38.70 47:13:36.2 13:30:14.95 47:10:27.6 + 698.5 811.4 1093.8 1300.2 236.1 864.8 + +... Match the lists using the ccxymatch "tolerance" algorithm and a matching +... tolerance of 2.0 arcseconds. Note the negative and positive signs on the +... xmag and ymag parameters and lack of any rotation, indicating that north +... is up and east is to the left. +cl> ccxymatch m51b.coo.1 m51b.gsc m51b.mat.4 2.0 refpoints=refpts \ +lngcolumn=2 latcolumn=4 matching=tolerance lngref=13:29:52.80 \ +latref=47:11:42.9 + +... Examine the matched list. +cl> type m51b.mat.4 + +# Input: m51b.coo.1 Reference: m51b.gsc Number of tie points: 3 +# tie point: 1 ref: 26.718 -97.698 input: 698.500 811.400 +# tie point: 2 ref: -143.629 113.354 input: 1093.800 1300.200 +# tie point: 3 ref: 225.854 -75.167 input: 236.100 864.800 +# +# Initial linear transformation +# xi[tie] = 327.7137 + -0.4306799 * x[tie] + -2.0406E-4 * y[tie] +# eta[tie] = -448.0854 + 0.00103896 * x[tie] + 0.430936 * y[tie] +# dx: 327.71 dy: -448.09 xmag: 0.431 ymag: 0.431 xrot: 179.9 yrot: 0.0 +# +# Column definitions +# Column 1: Reference Ra / Longitude coordinate +# Column 2: Reference Dec / Latitude coordinate +# Column 3: Input X coordinate +# Column 4: Input Y coordinate +# Column 5: Reference line number +# Column 6: Input line number + + + 13:30:07.960 47:05:18.30 401.034 147.262 17 42 + 13:29:48.600 47:07:42.50 860.002 480.061 8 44 + 13:29:37.400 47:09:09.20 1127.791 680.033 12 46 + 13:29:55.420 47:10:05.20 698.455 811.407 14 50 + 13:30:14.950 47:10:27.60 236.088 864.817 21 52 + 13:29:29.730 47:12:04.10 1307.802 1085.564 16 60 + 13:29:38.700 47:13:36.20 1093.813 1300.189 13 63 + + +... Compute the plate solution which is identical to the solution computed +... in example 2. +cl> ccmap m51b.mat.4 ccmap.db results=STDOUT xcolumn=3 ycolumn=4 lngcolumn=1 \ +latcolumn=2 refpoint=user lngref=13:29:52.8 latref=47:11:41 interactive=no +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +stsdas.gasp.regions,stsdas.gasp.skymap,tables.ttools.tprint,daophot.daofind,ccmap +.endhelp diff --git a/pkg/images/imcoords/doc/hpctran.hlp b/pkg/images/imcoords/doc/hpctran.hlp new file mode 100644 index 00000000..16a550c3 --- /dev/null +++ b/pkg/images/imcoords/doc/hpctran.hlp @@ -0,0 +1,109 @@ +.help hpctran Jul09 imcoords +.ih +NAME +hpctran -- Convert between HEALPix row and spherical coordinate +.ih +USAGE +hpctran lng=xxx lat=xxx +.br +hpctran row=xxx +.ih +PARAMETERS +.ls row +HEALPix table row (1 indexed). +This is used as input if the direction +is "row2ang" or is used to store the value if the direction is +"ang2row". +.le +.ls lng, lat +Spherical coordinate consisting of a longitude and latitude. +These are used as input if the direction +is "ang2row" or is used to store the value if the direction is +"row2ang". The units are interpreted as selected by the \fIcunits\fR +parameter. The type of coordinates appropriate for a particular map +is defined by the map provider. +.le +.ls nside = 512 +The number of pixels per face side. +.le +.ls cunits = "degrees" (degrees|hourdegree|radians) +The units of the longitude and latitude. The "hourdegree" is for +longitude in hours and latitude in degrees. +.le +.ls maptype = "nest" (nest|ring) +The map pixelization type which may be "nest" or "ring". +.le +.ls direction = "ang2row" (ang2row|row2ang) +The conversion direction. "ang2row" converts a spherical coordinate +to a map row or pixel number. "row2ang" converts a map row or pixel +number to a spherical coordinate. +.le +.ih +DESCRIPTION +HEALPix is an acronym for Hierarchical Equal Area isoLatitude Pixelization +of a sphere. See the reference section for a technical description of the +pixelization and mathematics. As suggested in the name, this pixelization, +or tiling, produces a subdivision of a spherical surface in which each +"pixel" covers the same surface area as every other pixel. A HEALPix FITS +"map" is a table where each row contains "pixel" data for a region on the +sphere. It is a table because the pixels don't form a raster as in an +image. + +The pixelization is defined by a resolution parameter which may be expressed +in various ways. This task uses the number of pixels along a side of one of +the 12 basic faces. The number of pixels/rows is 12 * nside * nside. The +pixelization has two forms supported by this task. These are called +"nested" and "ring". + +The HEALPix WCS task, \fBhpctran\fR, provides a translation between +the table row number and a spherical coordinate. It is up to the +creator of the table to choose the spherical coordinate system. This +might be an equatorial, galactic, or super-galactic system. There may +be a keyword specifying the system. This is the case with WMAP data. + +This task only provides the conversion. Access to the "pixel" data +requires other tools. For binary tables the \fBtables\fR may be used. + +This task allows the spherical coordinates to be input and output in three +forms, as hours and degrees (e.g. RA/DEC), as degrees (e.g. l/b), and as +radians. On input one may use sexagesimal since IRAF automatically converts +this to decimal. On output the values are produced in decimal form. + +The output is provide in two ways to provide flexibility in scripting. One +is writing the results to the task parameters. Note that it is recommended +that tasks which write to there parameter be "cached" with the \fBcache\fR +command to avoid problems with background submission or multiple scripts +running in parallel. The other output is printed to the standard output. +Regardless of the direction of conversion the printed output is in the same +order of row number, longitude, and latitude. + +.ih +EXAMPLES +A CMB WMAP file is obtained and one wants the temperature at a particular +point on the sky. Note that the WMAP format is "nested" and +coordinate system is galactic. + +.nf +cl> hpctran lng=50.12 lat=-33.45 +2298092 50.12 -33.45000000000001 +cl> = hpctran.row +2298092 +cl> tdump wmap_iqusmap_r9_5yr_K1_v3.fits col=TEMPERATURE row=2298092 +cl> tdump ("wmap_iqusmap_r9_5yr_K1_v3.fits", col="TEMPERATURE", +>>> row=hpctran.row) +.fi + +.ih +REFERENCE +\fIHEALPIX - a Framework for High Resolution Discretization, and Fast +Analysis of Data Distributed on the Sphere\fR, +by K.M. Gorski, Eric Hivon, A.J. Banday, B.D. Wandelt, F.K. Hansen, M. +Reinecke, M. Bartelmann, 2005, ApJ 622, 759. +.ih +CREDIT +Some code from the HEALPix distribution at http://healpix.jpl.nasa.gov +was translated to SPP for use in this routine. +.ih +SEE ALSO +ttools +.endhelp diff --git a/pkg/images/imcoords/doc/imcctran.hlp b/pkg/images/imcoords/doc/imcctran.hlp new file mode 100644 index 00000000..760f3caf --- /dev/null +++ b/pkg/images/imcoords/doc/imcctran.hlp @@ -0,0 +1,598 @@ +.help imcctran Oct00 images.imcoords +.ih +NAME +imcctran -- convert between image celestial coordinate systems +.ih +USAGE +imcctran image outsystem +.ih +PARAMETERS +.ls image +The list of images whose celestial coordinate systems are to be converted. The +image celestial coordinate system must be one of the standard FITS celestial +coordinate systems: equatorial (FK4, FK4-NO-E, FK5, ICRS, or GAPPT), ecliptic, +galactic, or supergalactic. +.le +.ls outsystem +The input and output celestial coordinate systems. The options are +the following: +.ls [wcs] +The celestial coordinate system is the world coordinate system of the image + and the input or output pixel coordinates may be in the +"logical", "tv", "physical" or "world" coordinate systems. If wcs is not +specified "logical" is assumed, unless the input coordinates are read from the +image cursor, in which case "tv" is assumed. The image celestial coordinate +system must be one of the valid FITS celestial coordinate systems: +equatorial (FK4, FK4-NO-E, FK5, or GAPPT), ecliptic, galactic, or +supergalactic. +.le +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for the fk5, icrs, galactic, and supergalactic +coordinate systems is required only if the input coordinates are in the +equatorial fk4, noefk4, fk5, or icrs systems and proper motions are defined. +.le +.ls nx = 10, ny = 10 +The dimensions of the coordinate grid used to compute the rotation angle and, +optionally, the x and y magnification factors required to transform the input +image celestial coordinate system to the output celestial coordinate system. +.le +.ls longpole = no +If longpole = yes the zenithal projections ARC, SIN, STG, TAN, and ZEA +will be transformed by updating the longpole and latpole parameters instead +of rotating the CD matrix in the usual manner. +.le +.ls verbose = yes +Print messages about actions taken by the task on the standard output ? +.le +.ls update = yes +Update the image celestial coordinate system ? +.le + +.ih +DESCRIPTION + +IMCCTRAN converts the celestial coordinate system stored in the headers of the +input images \fIimage\fR to the celestial coordinate system specified by +\fIoutsystem\fR, and updates the input image header appropriately. The input +and output celestial coordinate systems must be one of the following: +equatorial, ecliptic, galactic, or supergalactic. The equatorial coordinate +systems must be one of: 1) FK4, the mean place pre-IAU 1976 system, 2) FK4-NO-E, +the same as FK4 but without the E-terms, 3) FK5, the mean place post-IAU 1976 +system, 4), ICRS, the International Celestial Reference System, 5) GAPPT, +the geocentric apparent place in the post-IAU 1976 system. + +The input celestial coordinate system is read from the input image header. +IMCCTRAN assumes that the celestial coordinate system is specified by the FITS +keywords CTYPE, CRPIX, CRVAL, CD (or alternatively CDELT / CROTA), RADECSYS, +EQUINOX (or EPOCH), MJD-WCS (or MJD-OBS, or DATE-OBS). USERS SHOULD TAKE NOTE +THAT MJD-WCS IS CURRENTLY NEITHER A STANDARD OR A PROPOSED FITS STANDARD +KEYWORD. HOWEVER IT OR SOMETHING SIMILAR, IS REQUIRED TO SPECIFY THE EPOCH OF +THE COORDINATE SYSTEM WHICH MAY BE DIFFERENT FROM THE EPOCH OF THE OBSERVATION. + +The first four characters of the values of the ra / longitude and dec / latitude +axis CTYPE keywords specify the celestial coordinate system. The currently +permitted values of CTYPE[1:4] are RA-- / DEC- for equatorial coordinate +systems, ELON / ELAT for the ecliptic coordinate system, GLON / GLAT for the +galactic coordinate system, and SLON / SLAT for the supergalactic coordinate +system. + +The second four characters of the values of the ra / longitude and dec / +latitude axis CTYPE keywords specify the sky projection geometry. IRAF +currently supports the AIT, ARC, CAR, CSC, GLS, MER, PAR, PCO, QSC, +SIN, STG, TAN, TSC, and ZEA geometries as well as two internal projection +geometries TNX, and ZPX. Consequently the currently permitted values of +CTYPE[5:8] are -AIT, -ARC, -CAR, -CSC, -GLS, -MER, -PAR, -PCO, -QSC, +-SIN, -STG, -TAN, -TSC, -ZEA as well as -ZPX and -TNX. + +If the input image celestial coordinate system is equatorial, the value of the +RADECSYS keyword specifies which fundamental equatorial system is to be +considered. The permitted values of RADECSYS are FK4, FK4-NO-E, FK5, ICRS, +and GAPPT. If the RADECSYS keyword is not present in the image header, the +values of the EQUINOX / EPOCH keywords (in that order of precedence) are used +to determine the fundamental equatorial coordinate system. EQUINOX or EPOCH +contain the epoch of the mean place and equinox for the FK4, FK4-NO-E, FK5, +and ICRS systems (e.g 1950.0 or 2000.0). The default equatorial system is +FK4 if EQUINOX or EPOCH < 1984.0, FK5 if EQUINOX or EPOCH >= 1984.0, and FK5 +if RADECSYS, EQUINOX, and EPOCH are undefined. If RADECSYS is defined but +EQUINOX and EPOCH are not, the equinox defaults to 1950.0 for the FK4 and +FK4-NO-E systems, and 2000.0 for the FK5 and ICRS systems. The equinox value is +interpreted as a Besselian epoch for the FK4 and FK4-NO-E systems, and as a +Julian epoch for the FK5 and ICRS systems. Users are +strongly urged to use the EQUINOX keyword in preference to the EPOCH keyword, +if they must enter their own equinox values into the image header. The FK4 and +FK4-NO-E systems are not inertial and therefore also require the epoch of the +observation (the time when the mean place was correct), in addition to the +equinox. The epoch is specified, in order of precedence, by the values of the +keywords MJD-WCS or MJD-OBS (which contain the modified Julian date, JD - +2400000.5, of the coordinate system), or the DATE-OBS keyword (which contains +the date of the observation in the form DD/MM/YY, CCYY-MM-DD, or +CCYY-MM-DDTHH:MM:SS.S). As the latter quantity may +only be accurate to a day, the MJD-WCS or MJD-OBS specification is preferred. +If all 3 keywords are absent the epoch defaults to the value of equinox. +Equatorial coordinates in the GAPPT system require only the specification +of the epoch of observation which is supplied via the MJD-WCS, MJD-OBS, +or DATE-OBS keywords (in that order of precedence) as for the FK4 and +FK4-NO-E system. + +If the input image celestial coordinate system is ecliptic the mean ecliptic +and equinox of date are required. These are supplied via the MJD-WCS, MJD-OBS, +or DATE-OBS keywords (in that order or precedence) as for the equatorial FK4, +FK4-NO-E, and GAPPT systems. + +The output coordinate system is specified by the \fIoutsystem\fR parameter +as described in the PARAMETERS section. + +If an error is encountered when decoding the input or output world coordinate +systems, an error message is printed on the standard output (if \fIverbose\fR +is "yes"), and the input image left unmodified. + +If the input projection is one of the zenithal projections TAN, SIN, STG, +ARC, or ZEA, then the header coordinate transformation can be preformed by +transforming the CRVAL parameters and rotating the CD matrix as described in +detail below. Otherwise the CRVAL values are transformed, the CD matrix is +left unmodified, and the LONGPOLE and LATPOLE parameters required to perform +the rotation are computed. If \fIlongpole\fR is yes then the zenithal +coordinate systems will also be transformed using LONGPOLE and LATPOLE. At +present IRAF looks for longpole and latpole parameters in the appropriate +WATN_* keywords. If these are undefined the appropriate default values for +each projection are assumed and new values are written to the WATN_* keywords. + +The new image celestial coordinate system is computed as follows. First a +grid of \fInx\fR by \fIny\fR pixel and celestial coordinates, evenly spaced +over the input image, is generated using the input image celestial coordinate +system. Next these input celestial coordinates are transformed to coordinates +in the output celestial coordinate system. Next the input celestial coordinates +of the reference point (stored in degrees in the input image CRVAL keywords) +are transformed to coordinates in the output celestial coordinate system, +and new x and y pixel coordinates are computed using the transformed reference +point coordinates but the original input CD matrix. The differences +between the predicted and initial x and y pixel coordinates are used to +compute the x and y axis rotation angles and the x and y magnification factors +required to transform the original CD matrix to the correct new CD matrix. +The process is shown schematically below. + +.nf +1. x,y(input grid) -> ra,dec(input grid) + +2. ra,dec(input grid) -> ra,dec(output grid) + +3. ra_ref,dec_ref(input) -> ra_ref,dec_ref(output) + +4. ra,dec(output grid) -> x,y(predicted grid) + +5. x,y(input grid) -> F -> x,y(predicted grid) + +6. cd matrix(input) -> F -> cd matrix(output) +.fi + +F is the fitted function of the x and y axis rotation angles and the +x and y scaling factors required to match the input x and y values to the +predicted x and y values. + +For most celestial coordinate transformations the fitted x and y scale factors +will be very close to 1.0 and the x and y rotation angles will be almost +identical. However small deviations from unity scale factors and identical +x and y axis rotation angles do occur when transforming coordinates systems +with the skewed axes. + +The precision of the transformations is usually very high, on the order +of 10E-10 to 10E-11 in most cases. However conversions to and from the FK4 +equatorial system are less precise as these transformations +involve the addition and subtraction of the elliptical aberration +or E-terms. In this case the x and y scale factors correct for the first +order E-terms and do significantly improve the precision of the coordinate +transformation. The quadratic terms, i.e. terms in xy, x**2, and y**2 +however are not corrected for, and their absence does diminish the precision +of the transformation coordinate transformation. For most practical purposes +this loss of precision is insignificant. + +After the fit is completed, the celestial coordinates of the reference point +in dd:mm:ss.s in the old and new systems, the rotation angle in degrees, the x +and y scaling factors, and an estimate of the rms error of the x and y +coordinate transformation are printed on the standard output. + +If \fIupdate\fR is yes, then the image header parameters CRVAL, CD, +CTYPE, RADECSYS, EQUINOX, EPOCH, and MJD-WCS are modified, deleted, or +added as appropriate. The position of the reference pixel in the +image (stored in the CRPIX keywords), and the sky projection geometry, e.g. +TAN, SIN, ARC, ETC are unchanged. + +USERS NEED TO BE AWARE THAT THE IRAF IMAGE WORLD COORDINATE SYSTEM +CURRENTLY (IRAF VERSIONS 2.10.4 PATCH 2 AND EARLIER) SUPPORTS ONLY THE +EQUATORIAL SYSTEM (CTYPE (ra axis) = "RA--XXXX" CTYPE (dec axis) = "DEC-XXXX") +WHERE XXXX IS THE PROJECTION TYPE, EVEN THOUGH THE IMCCTRAN TASK +SUPPORTS GALACTIC, ECLIPTIC, AND SUPERGALACTIC COORDINATES. IMCCTRAN will +update the image correctly for non-equatorial systems, but IRAF will +not be able to read these transformed image coordinate systems correctly. + +USERS SHOULD ALSO REALIZE THAT IMAGE WORLD COORDINATE SYSTEM REPRESENTATION +IN FITS IS STILL IN THE DRAFT STAGE. ALTHOUGH IMCCTRAN TRIES TO CONFORM TO +THE CURRENT DRAFT PROPOSAL AS MUCH AS POSSIBLE, WHERE NO ADOPTED STANDARDS +CURRENTLY EXIST, THE FINAL FITS STANDARD MAY DIFFER FROM THE ONE ADOPTED HERE. + +.ih +REFERENCES + +Additional information on the IRAF world coordinate systems can be found in +the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + +.ih +EXAMPLES + +[1]. Precess the equatorial FK5 J2000 celestial coordinate system of the +input 512 by 512 pixel square input image to J1975.0. + +.nf +cl> imcctran image j1975.0 + +INPUT IMAGE: image +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J2000.000 + Epoch: J1987.25667351 MJD: 46890.00000 +Outsystem: j1975 Coordinates: equatorial FK5 + Equinox: J1975.000 Epoch: J1975.00000000 MJD: 42413.25000 +Crval1,2: 201:56:43.5, 47:27:16.0 -> 201:40:53.8, 47:35:01.2 dd:mm:ss.s + Scaling: Xmag: 1.000000 Ymag: 1.000000 Xrot: 359.923 Yrot: 359.923 degrees + Rms: X fit: 8.465123E-11 pixels Y fit: 5.204446E-11 pixels +.fi + +Before the transformation the image coordinate system looked like the following. + +.nf + ... + EPOCH = 2000 + DATE-OBS= '05/04/87' + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 201.94541667302 + CRVAL2 = 47.45444 + CDELT1 = -2.1277777E-4 + CDELT2 = 2.1277777E-4 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + ... +.fi + +After the transformation the header looks like the following. + +.nf + ... + DATE-OBS= '05/04/87' + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 201.681616387759 + CRVAL2 = 47.583668865029 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + RADECSYS= 'FK5 ' + EQUINOX = 1975. + MJD-WCS = 42413.25 + WCSDIM = 2 + CD1_1 = -2.1277757990523E-4 + CD1_2 = 2.84421945372844E-7 + CD2_1 = 2.84421945363011E-7 + CD2_2 = 2.12777579905235E-4 + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=image' + WAT1_001= 'wtype=tan axtype=ra' + WAT2_001= 'wtype=tan axtype=dec' + ... +.fi + +Note the rms of the x and y fits is on the order 10.0e-10 to 10.0e-11 which +is the expected numerical precision of the transformation. + + +[2]. Convert the input image used in example 1 to the BFK4 1950.0 system. + +.nf +cl> imcctran image B1950.0 + +INPUT IMAGE: image +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J2000.000 + Epoch: J1987.25667351 MJD: 46890.00000 +Outsystem: B1950 Coordinates: equatorial FK4 + Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 +Crval1,2: 201:56:43.5, 47:27:16.0 -> 201:25:02.3, 47:42:47.1 dd:mm:ss.s + Scaling: Xmag: 0.999999 Ymag: 0.999999 Xrot: 359.848 Yrot: 359.848 degrees + Rms: X fit: 1.302837E-7 pixels Y fit: 8.545616E-8 pixels + +.fi + +Note that precision of the transformation is still good but is significantly +less that the precision of the previous example. This is due to the fact +that the quadratic terms in the E-term computation are not included in the +transformation. + +The transformed image header in this case looks like the following. + +.nf + ... + DATE-OBS= '05/04/87' + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 201.417300629944 + CRVAL2 = 47.7130749603847 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + RADECSYS= 'FK4 ' + EQUINOX = 1950. + MJD-WCS = 33281.92345905 + WCSDIM = 2 + CD1_1 = -2.1277680505752E-4 + CD1_2 = 5.66226465943254E-7 + CD2_1 = 5.66226470798410E-7 + CD2_2 = 2.12776805056766E-4 + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=image' + WAT1_001= 'wtype=tan axtype=ra' + WAT2_001= 'wtype=tan axtype=dec' + ... +.fi + + +[3]. Transform the celestial coordinate system of the input image used in +examples 1 and 2 to the galactic coordinate system. + +.nf +cl> imcctran image galactic + +INPUT IMAGE: image +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J2000.000 + Epoch: J1987.25667351 MJD: 46890.00000 +Outsystem: galactic Coordinates: galactic + MJD: 33281.92346 Epoch: J1949.99979044 B1950.00000000 +rval1,2: 201:56:43.5, 47:27:16.0 -> 106:01:19.4, 68:27:46.1 dd:mm:ss.s + Scaling: Xmag: 1.000000 Ymag: 1.000000 Xrot: 202.510 Yrot: 202.510 degrees + Rms: X fit: 9.087450E-11 pixels Y fit: 3.815443E-11 pixels +.fi + +The transformed header looks like the following. + +.nf + ... + DATE-OBS= '05/04/87' + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 106.022047915293 + CRVAL2 = 68.4627934475432 + CTYPE1 = 'GLON-TAN' + CTYPE2 = 'GLAT-TAN' + MJD-WCS = 33281.92345905 + WCSDIM = 2 + CD1_1 = 1.96567112095654E-4 + CD1_2 = 8.14601120181094E-5 + CD2_1 = 8.14601120174619E-5 + CD2_2 = -1.9656711209802E-4 + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=image' + WAT1_001= 'wtype=tan axtype=glon' + WAT2_001= 'wtype=tan axtype=glat' + ... +.fi + +Users should not that although imcctran can write a legal galactic coordinate +system to the image header, it and other iraf tasks cannot currently +read this coordinate system. + +[4]. Repeat the previous example but don't update the image header. + +.nf +cl> imcctran image galactic update- + +INPUT IMAGE: image +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J2000.000 + Epoch: J1987.25667351 MJD: 46890.00000 +Outsystem: galactic Coordinates: galactic + MJD: 33281.92346 Epoch: J1949.99979044 B1950.00000000 + +Current wcs + Axis 1 2 + Crval 201.9454 47.4544 + Crpix 257.75 258.93 + Cd 1 -2.128E-4 0. + Cd 2 0. 2.128E-4 + +New wcs + Axis 1 2 + Crval 106.0220 68.4628 + Crpix 257.75 258.93 + Cd 1 1.966E-4 8.146E-5 + Cd 2 8.146E-5 -1.966E-4 + +Crval1,2: 201:56:43.5, 47:27:16.0 -> 106:01:19.4, 68:27:46.1 dd:mm:ss.s + Scaling: Xmag: 1.000000 Ymag: 1.000000 Xrot: 202.510 Yrot: 202.510 degrees + Rms: X fit: 9.087450E-11 pixels Y fit: 3.815443E-11 pixels +.fi + +[5]. Repeat example 1 and check the accuracy of the results by using the +skyctran task on the original image and on the transformed image. + +.nf +cl> type coords + 1.0 1.0 +512.0 1.0 +512.0 512.0 + 1.0 512.0 + +cl> skyctran coords STDOUT "image logical" J1975.0 + +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J2000.000 + Epoch: J1987.25667351 MJD: 46890.00000 +Outsystem: j1975 Coordinates: equatorial FK5 + Equinox: J1975.000 Epoch: J1975.00000000 MJD: 42413.25000 + +Input file: coords Output file: STDOUT + + 1.0 1.0 13:27:02.9797 47:31:43.269 +512.0 1.0 13:26:24.3330 47:31:43.793 +512.0 512.0 13:26:24.3448 47:38:15.219 + 1.0 512.0 13:27:03.0718 47:38:14.693 + +cl> imcctran image j1975.0 + +cl> skyctran coords STDOUT "image logical" "image world" + +Insystem: image logical Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J1975.000 + Epoch: J1975.00000000 MJD: 42413.25000 +Outsystem: image world Projection: TAN Ra/Dec axes: 1/2 + Coordinates: equatorial FK5 Equinox: J1975.000 + Epoch: J1975.00000000 MJD: 42413.25000 + +Input file: coords Output file: STDOUT + + 1.0 1.0 13:27:02.9797 47:31:43.269 +512.0 1.0 13:26:24.3330 47:31:43.793 +512.0 512.0 13:26:24.3448 47:38:15.219 + 1.0 512.0 13:27:03.0718 47:38:14.693 +.fi + +.ih +TIME REQUIREMENTS + +.ih +BUGS + +At present IRAF requires that the LONGPOLE and or LATPOLE keywords be +defined in the appropriate WAT_* keywords, e.g. WAT1_* and WAT2_* for +a 2D image. If these are not present then default values are assumed. +The new values are computed and added to the WAT1_* and WAT2_* keywords. + +At present the experimental TNX and ZPX projections cannot be transformed +with precision. Users should use the SKYCTRAN task to transform individual +coordinate pairs. + +.ih +SEE ALSO +setjd,precess,galactic,xray.xspatial.skypix,stsdas.toolbox.tools.tprecess +.endhelp diff --git a/pkg/images/imcoords/doc/mkcwcs.hlp b/pkg/images/imcoords/doc/mkcwcs.hlp new file mode 100644 index 00000000..542e4ff9 --- /dev/null +++ b/pkg/images/imcoords/doc/mkcwcs.hlp @@ -0,0 +1,93 @@ +.help mkcwcs Jun05 images.imcoords +.ih +NAME +mkcwcs -- make or update a simple celestial wcs +.ih +USAGE +mkcwcs wcsname +.ih +PARAMETERS +.ls wcsname +Image to be created or modified. If a new (non-existent) image is specified +then a data-less image (NDIM=0) is created. +.le +.ls wcsref = "" +Image whose WCS is first inherited and then updated. +.le + +.ls equinox = INDEF +Equinox of the coordinates specified in decimal years. If INDEF then the +current value is not modified. +.le +.ls ra = INDEF +Right ascension in hours. This may be typed in standard sexagesimal +notation though it will be converted to decimal hours in EPARAM and +to decimal degrees in the WCS as required by the standard. If INDEF +then the current value is not modified. +.le +.ls dec = INDEF +Declination in degrees. This may be typed in standard sexagesimal +notation though it will be converted to decimal degrees in EPARAM. +If INDEF then the current value is not modified. +.le +.ls scale = INDEF, pa = 0., lefthanded = yes +Celestial pixel scale in arc seconds per pixel, the position angle in +degrees, and the handedness of the axes. These are all represented by +the WCS rotation matrix. If the scale is INDEF the current +rotation matrix is unchanged and the position angle is ignored. If the +scale is not INDEF then orthogonal axes are defined with the same scale on +both axes. The handedness of the axes are specified by the +\fIlefthanded\fR parameter. The position angle is measured from north +increasing with the image lines (up in a standard display) and rotated +towards east. Note that if the axes are lefthanded the angle is +counterclockwise and if not it is clockwise. +.le +.ls projection = "tan" (tan|sin|linear) +WCS projection function which may be "tan", "sin", or "linear". +.le +.ls rapix = INDEF, decpix = INDEF +The reference pixel for the right ascension (first image axis) and for +the declination (second image axes). The reference pixel may be fractional +and lie outside the size of the image as allowed by the standard. +.le +.ih +DESCRIPTION +MKCWCS creates or modifies a celestial (RA/DEC) WCS in an image header. If a +new image is specified the WCS is created in a data-less image header. A +data-less WCS may be used in various tasks as a template. If a reference +WCS is specified it is copied in whole and then desired elements of the WCS +are modified. If a new WCS is created without a reference the initial values +are for the pixel coordinates. + +The elements of the WCS which may be set are the coordinate equinox, +the right ascension and declination, the pixel scale, the axes orientation, +and the reference pixel in the image which corresponds to the specified +right ascension and declination. If values are specified they WCS elements +are left unchanged. + +The WCS is simple and not completely general because it defines the first +coordinate axis to be right ascension and the second to be declination and +that the axes are orthogonal with a uniform pixel scale (apart from the +projection function). +.ih +EXAMPLES +1. Create a data-less header by specifying a new wcs name. + +.nf + cl> mkcwcs new ra=1:20:23.1 dec=-12:11:13 scale=0.25 +.fi + +The reference pixel will be (0,0). To apply it later to an actual +image (say with WCSCOPY) would require assigning the reference pixel. +Note the use of sexagesimal notation. + +2. Modify the WCS of an existing image by changing the reference value +and pixel. + +.nf + cl> mkcwcs old ra=1:20:23.1 dec=-12:11:13 rapix=1234 decpix=345 +.fi +.ih +SEE ALSO +wcsedit,wcscopy,mkcwwcs +.endhelp diff --git a/pkg/images/imcoords/doc/mkcwwcs.hlp b/pkg/images/imcoords/doc/mkcwwcs.hlp new file mode 100644 index 00000000..7140aa8c --- /dev/null +++ b/pkg/images/imcoords/doc/mkcwwcs.hlp @@ -0,0 +1,110 @@ +.help mkcwwcs Jun05 images.imcoords +.ih +NAME +mkcwwcs -- make or update a simple celestial/wavelength wcs +.ih +USAGE +mkcwwcs wcsname +.ih +PARAMETERS +.ls wcsname +Image to be created or modified. If a new (non-existent) image is specified +then a data-less image (NDIM=0) is created. +.le +.ls wcsref = "" +Image whose WCS is first inherited and then updated. +.le + +.ls equinox = INDEF +Equinox of the coordinates specified in decimal years. If INDEF then the +current value is not modified. +.le +.ls ra = INDEF +Right ascension in hours. This may be typed in standard sexagesimal +notation though it will be converted to decimal hours in EPARAM and +to decimal degrees in the WCS as required by the standard. If INDEF +then the current value is not modified. +.le +.ls dec = INDEF +Declination in degrees. This may be typed in standard sexagesimal +notation though it will be converted to decimal degrees in EPARAM. +If INDEF then the current value is not modified. +.le +.ls scale = INDEF, pa = 0., lefthanded = yes +Celestial pixel scale in arc seconds per pixel, the position angle in +degrees, and the handedness of the axes. These are all represented by +the WCS rotation matrix. If the scale is INDEF the current +rotation matrix is unchanged and the position angle is ignored. If the +scale is not INDEF then orthogonal axes are defined with the same scale on +both axes. The handedness of the axes are specified by the +\fIlefthanded\fR parameter. The position angle is measured from north +increasing with the image lines (up in a standard display) and rotated +towards east. Note that if the axes are lefthanded the angle is +counterclockwise and if not it is clockwise. +.le +.ls projection = "tan" (tan|sin|linear) +WCS projection function for the celestial axes which may be +"tan", "sin", or "linear". +.le + +.ls wave = INDEF +Reference wavelength in arbitrary units. If INDEF then the current +value is not modified. +.le +.ls wscale = INDEF +Wavelength scale in arbitrary units per pixel. If INDEF then the current +value is not modified. +.le + +.ls rapix = INDEF, decpix = INDEF, wpix = INDEF +The reference pixel for the right ascension (first image axis), for +the declination (second image axes), and for the wavelength +(third axis). The reference pixel may be fractional +and lie outside the size of the image as allowed by the standard. +.le +.ih +DESCRIPTION +MKCWWCS creates or modifies a celestial (RA/DEC) plus wavelength +three-dimensional WCS in an image header. If a +new image is specified the WCS is created in a data-less image header. A +data-less WCS may be used in various tasks as a template. If a reference +WCS is specified it is copied in whole and then desired elements of the WCS +are modified. If a new WCS is created without a reference the initial values +are for the pixel coordinates. + +The elements of the WCS which may be set are the coordinate equinox, +the right ascension and declination, the pixel scale, the axes orientation, +the reference wavelength, the wavelength scale (i.e. dispersion), +and the reference pixel in the image which corresponds to the specified +right ascension and declination. If values are specified the WCS elements +are left unchanged. + +The WCS is simple and not completely general because it defines the first +coordinate axis to be right ascension, the second to be declination, and +the third to be wavelength. The axes are orthogonal and the celestial axes +have a uniform pixel scale (apart from the effects of the projection +function). +.ih +EXAMPLES +1. Create a data-less header by specifying a new wcs name. + +.nf + cl> mkcwwcs new ra=1:20:23.1 dec=-12:11:13 wave=5500. \ + >>> scale=0.25 wscale=1.23 +.fi + +The reference pixel will be (0,0,0). To apply it later to an actual +image (say with WCSCOPY) would require assigning the reference pixel. +Note the use of sexagesimal notation. + +2. Modify the WCS of an existing image by changing the reference value +and pixel. + +.nf + cl> mkcwwcs old ra=1:20:23.1 dec=-12:11:13 wave=5500. \ + >>> rapix=1234 decpix=345 wpix=1024 +.fi +.ih +SEE ALSO +wcsedit,wcscopy,mkcwcs +.endhelp diff --git a/pkg/images/imcoords/doc/skyctran.hlp b/pkg/images/imcoords/doc/skyctran.hlp new file mode 100644 index 00000000..d91dd983 --- /dev/null +++ b/pkg/images/imcoords/doc/skyctran.hlp @@ -0,0 +1,861 @@ +.help skyctran Jun99 images.imcoords +.ih +NAME +skyctran -- convert astronomical coordinates from one system to another +.ih +USAGE +skyctran input output insystem outsystem +.ih +PARAMETERS +.ls input +The source of the input coordinates. The options are: +.ls +The list of input coordinate files. Coordinates may be entered by hand by +setting input to "STDIN". A STDIN coordinate list is terminated by typing +q or (usually or ). +.le +.ls imcursor +If the input file name is equal to the reserved keyword "imcursor" the input +coordinates are read from the image cursor and the input coordinate system +is the coordinate system of the image specified by the insystem parameter. +The coordinate list is terminated by typing q or (usually or +). +.le +.ls grid +If the input file name is equal to the reserved +keyword "grid", an \fInilng\fR by \fInilat\fR grid of equally spaced +input coordinates +is generating spanning the region defined by \fIilngmin\fR, \fIilngmax\fR, +\fIilatmin\fR, \fIilatmax\fR. +.le +.le +.ls output +The list of output coordinate files. The number of output files must be +equal to one or the number of input files. Results may be printed on the +terminal by setting output to "STDOUT". +.le +.ls insystem, outsystem +The input and output celestial coordinate systems. The options are +the following: +.ls [wcs] +The celestial coordinate system is the world coordinate system of the image + and the input or output pixel coordinates may be in the +"logical", "tv", "physical" or "world" coordinate systems. If wcs is not +specified "logical" is assumed, unless the input coordinates are read from the +image cursor, in which case "tv" is assumed. The image celestial coordinate +system must be one of the valid FITS celestial coordinate systems: +equatorial (FK4, FK4-NO-E, FK5, ICRS, or GAPPT), ecliptic, galactic, or +supergalactic. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reverence System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +In all the above cases fields in [] are optional with the defaults as +described. The epoch field for fk5, icrs, galactic, and supergalactic +coordinate systems is required only if the input coordinates are in the +equatorial fk4, noefk4, fk5, or icrs systems and proper motions are defined. +.le +.ls transform = no +If transform = no the computed output coordinates are appended to the +input line and the new extended line is written to the output file. If +transform = yes the computed output coordinates replace +the input coordinates in the input line and the edited line is written +to the output file. Transform is always set to "no" if the input +is from the unredirected standard input. +.le +.ls lngcolumn = 1, latcolumn = 2 +The columns in the input file containing the x/ra/longitude and +y/dec/latitude coordinates. Lngcolumn and latcolumn are always 1 and +2 if the input is from the unredirected standard input. +.le +.ls plngcolumn = INDEF, platcolumn = INDEF +The columns in the input file containing the ra and dec proper motions +in " / year. If plngcolumn and platcolumn are INDEF the proper motions +are assumed to be undefined. Proper motions +are used only if the input coordinate system is equatorial fk4, noefk4, +fk5, or icrs. Plngcolumn and platcolumn are always 3 and 4 if the input is from +the unredirected standard input. +.le +.ls pxcolumn = INDEF, rvcolumn = INDEF +The columns in the input file containing the parallax and radial velocity in +in " and km / sec respectively. If pxcolumn and rvcolumn are INDEF, the +parallax and radial velocities are assumed to be 0.0 and 0.0. +Parallaxes and radial velocities are only used if proper motions are +defined. Pxcolumn and rvcolumn are always 5 and 6 if the input is from the +unredirected standard input. +.le +.ls ilngmin = INDEF, ilngmax = INDEF, ilatmin = INDEF, ilatmax = INDEF +The lower and upper limits of the coordinate grid if \fIinput\fR = +"grid". +Ilngmin and ilngmax default to 1.0, 1.0, 0.0, 0.0, 0.0 and, 2048.0, ncols, 24.0, +360.0, and TWOPI for coordinates in units of INDEF, pixels, hours, degrees, +and radians respectively. Ilatmin and ilatmax default to 1.0, 1.0, +-90.0, -90.0, -HALFPI and, 2048.0, nlines, 90.0, 90.0, and HALFPI +for units of INDEF, pixels, degrees, degrees, and radians respectively. +.le +.ls nilng = 10, nilat = 10 +The size of the computed coordinate grid if \fIinput\fR = "grid". +.le +.ls ilngunits = "", ilatunits = "" +The units of the input ra/longitude and dec/latitude coordinates. +The options are: +.ls hours +Read the sky coordinates in hours. +.le +.ls degrees +Read the sky coordinates in degrees. +.le +.ls radians +Read the sky coordinates in radians. +.le + +If the input system is the [logical/tv/physical] +system, pixel units are assumed regardless of the values +of ilngunits or ilatunits. The default ilngunits and +ilatunits values are +hours and degrees for the equatorial coordinate systems and degrees and +degrees for the remaining sky coordinate systems. +.le +.ls ilngformat = "", ilatformat = "" +The output format of the input x/ra/longitude and y/dec/latitude coordinates +if \fIinput\fR = "grid". +The options are discussed in the formats section of the help page below. +If the input coordinate system is the [logical/tv/physical] +system, default formats of %10.3f and %10.3f are assumed regardless +of the values of ilngunits and ilatunits. Otherwise default formats +of %12.3h, %12.2h, and %13.7g are assumed for input units of "hours", "degrees", +and "radians" respectively. For values of \fIinput\fR other than "grid" +the output formats of the input coordinates are the same as the input +formats. +.le +.ls olngunits = "", olatunits = "" +The units of the output ra/longitude and dec/latitude coordinates. +The options are: +.ls hours +Output the sky coordinates in hours. +.le +.ls degrees +Output the sky coordinates in degrees. +.le +.ls radians +Output the sky coordinates in radians. +.le + +If the output system is the [logical/tv/physical] +system, pixel units are assumed regardless of the values +of olngunits or olatunits. The default olngunits and +olatunits values are +hours and degrees for the equatorial coordinate systems and degrees and +degrees for the remaining sky coordinate systems. +.le +.ls olngformat = "", olatformat = "" +The format of the computed x/ra/longitude and y/dec/latitude coordinates. +The options are discussed in the formats section of the help page below. +If the output coordinate system is the [logical/tv/physical] +system, default formats of %10.3f and %10.3f are assumed regardless +of the values of olngunits and olatunits. Otherwise default formats +of %12.3h, %12.2h, and %13.7g are assumed for output units of "hours", +"degrees", and "radians" respectively. +.le +.ls icommands = "" +The default image display cursor. +.le +.ls verbose = yes +Print messages about actions taken by the task on the standard output? +.le + +.ih +DESCRIPTION + +SKYCTRAN converts coordinates in the input files +\fIinput\fR from the input celestial coordinate system \fIinsystem\fR +to the output celestial coordinate system \fIoutsystem\fR and writes the +converted coordinates to the output files \fIoutput\fR. The input +files may be simple text files, the standard input "STDIN", +the image display cursor "imcursor", or a user specified coordinate grid. +The output files may be simple +text files or the standard output "STDOUT". SKYCTRAN may be used +to change the units of the input coordinates, e.g. from degrees and degrees +to hours and degrees, to precess the coordinates, to convert from one +celestial coordinate system to another, e.g. from equatorial to ecliptic +coordinates and vice versa, and to locate common objects in +images whose fundamental coordinate systems are the same but observed at +different epochs, e.g. FK4 B1950.0 and FK4 B1975.0, or different, e.g. +equatorial FK4 B1950.0 and galactic. + +The input data are read from columns \fIlngcolumn\fR, \fIlatcolumn\fR, +\fIplngcolumn\fR, \fIplatcolumn\fR, \fIpxcolumn\fR, and \fIrvcolumn\fR +in the input files and if \fItransform\fR = yes, the converted coordinates are +written to the same columns in the output files. If \fItransform\fR = "no", +the converted coordinates are appended to the input line creating two +additional columns in the output file. If the input file is the +unredirected standard input then transpose is always "no". Comment lines, blanks +lines, and lines for which the input coordinates could not be successfully +decoded are passed on to the output file without modification. + +The input and output celestial coordinate systems \fIinsystem\fR and +\fIoutsystem\fR must be one of the following: equatorial, ecliptic, galactic, or +supergalactic. The equatorial systems must be one of: 1) FK4, the mean +place pre-IAU 1976 system, 2) FK4-NO-E, the same as FK4 but without the +E-terms, 3) FK5, the mean place post-IAU 1976 system, 4) ICRS, +the International Celestial Reference System, 5) GAPPT, the geocentric +apparent place in the post-IAU 1976 system. + +If \fIinsystem\fR or \fIoutsystem\fR is an image name then the celestial +coordinate system is read from the image header. SKYCTRAN assumes that +the celestial coordinate system is represented in the image header by +the FITS keywords CTYPE, CRPIX, CRVAL, CD (or alternatively CDELT / CROTA), +RADECSYS, EQUINOX (or EPOCH), and MJD-WCS (or MJD_OBS or DATE-OBS). USERS +SHOULD TAKE NOTE THAT MJD-WCS IS CURRENTLY NEITHER A STANDARD OR +PROPOSED FUTS STANDARD KEYWORD. HOWEVER IT OR SOMETHING SIMILAR IS REQUIRED +TO SPECIFY THE EPOCH OF THE COORDINATE SYSTEM WHICH MAY BE DIFFERENT +FROM THE EPOCH OF THE OBSERVATION. + +The first four characters of the values of the ra/longitude and dec/latitude +axis CTYPE keywords specify the celestial coordinate system. +The permitted CTYPE values are RA--/DEC- for equatorial coordinate systems, +ELON/ELAT for the ecliptic coordinate system, GLON/GLAT for the galactic +coordinate system, and SLON/SLAT for the supergalactic coordinate system, + +If the image celestial coordinate system is equatorial, the value +of the RADECSYS keyword specifies the fundamental equatorial system. +The permitted values of RADECSYS are FK4, FK4-NO-E, +FK5, ICRS, and GAPPT. If the RADECSYS keyword is not +present in the image header, the values of the EQUINOX or EPOCH keywords +in that order of precedence are used to determine the fundamental +equatorial system. EQUINOX or EPOCH contain the +epoch of the mean place and equinox for the FK4, FK4-NO-E, FK5, and ICRS +systems, e.g 1950.0 or 2000.0. The default equatorial system is FK4 if +EQUINOX or EPOCH < 1984.0, FK5 if EQUINOX or EPOCH >= 1984.0, and FK5 if +RADECSYS, EQUINOX and EPOCH are undefined. +If RADECSYS is defined but EQUINOX and EPOCH are not the equinox +defaults to 1950.0 for the FK4 and FK4-NO-E systems and 2000.0 for the FK5 +and ICRS systems. +The equinox value is interpreted as a Besselian epoch for the FK4 and +FK4-NO-E systems and as a Julian epoch for the FK5 and ICRS systems. Users are +strongly urged to use the EQUINOX keyword in preference to the EPOCH +keyword if they must enter their own values of the equinox into +the image header. The FK4 and +FK4-NO-E systems are not inertial and therefore also require the epoch of the +observation (the time when the mean place was correct) in addition to the +equinox. The input coordinate system epoch of the observation is also required +if the input coordinate system is FK4, FK4-NO-E, FK5, or ICRS and proper motions +are supplied. +The epoch is specified, in order of precedence, by the values of +the keywords MJD-WCS or MJD-OBS containing the modified Julian date +(JD - 2400000.5) of +the coordinate system, or the DATE-OBS keyword containing +the date of the observation in the form DD/MM/YY, CCYY-MM-DD, or +CCYY-MM-DDTHH:MM:SS.S. As the latter quantity may +only be accurate to a day, the MJD-WCS or MJD-OBS specifications are +preferable. If both +keywords are absent the epoch defaults to the value of equinox. +Equatorial coordinates in the GAPPT system require +only the specification of the epoch of observation which is supplied +via the MJD-WCS, MJD-OBS or DATE-OBS keywords as for the FK4, FK4-NO-E, FK5, +and ICRS systems. + +If the celestial coordinate system is ecliptic the mean ecliptic and equinox of +date are required. They are supplied via the MJD-WCS, MJD-OBS or DATE-OBS +keywords as for the equatorial FK4, FK4-NO-E, FK5, ICRS, and GAPPT systems. + +If, the output coordinate system is galactic or supergalactic, the input +coordinate system is FK4, FK4-NO-E, FK5, or ICRS and proper motions are +supplied with the input coordinates, then the output epoch of the +observation is also required. This is supplied via the MJD-WCS, MJD-OBS or +DATE-OBS keywords as for the equatorial FK4, FK4-NO-E, FK5, ICRS, GAPPT, +and ecliptic systems. + +USERS NEED TO BE AWARE THAT THE IRAF IMAGE WORLD COORDINATE SYSTEM +CURRENTLY (IRAF VERSIONS 2.10.4 PATCH 2 AND EARLIER) SUPPORTS ONLY THE +EQUATORIAL SYSTEM (CTYPE (ra axis) = "RA--XXXX" CTYPE (dec axis) = "DEC-XXXX") +WHERE XXXX IS THE PROJECTION TYPE, EVEN THOUGH THE SKYCTRAN TASK +SUPPORTS GALACTIC, ECLIPTIC, AND SUPERGALACTIC COORDINATES. + +USERS SHOULD ALSO REALIZE THAT IMAGE WORLD COORDINATE SYSTEM REPRESENTATION +IN FITS IS STILL IN THE DRAFT STAGE. ALTHOUGH SKYCTRAN TRIES TO CONFORM TO +THE CURRENT DRAFT PROPOSAL WHERE NO ADOPTED STANDARDS CURRENTLY EXIST, THE +FINAL FITS STANDARD MAY DIFFER FROM THE ONE ADOPTED HERE. + +The IRAF builtin world coordinate systems "logical", "tv", "physical", and +world are also supported. This means for example that users can begin +with cursor coordinates in image 1, use the image header of image 1 +to transform the pixel coordinates to the celestial coordinate system of +image 1, convert the image 1 celestial coordinates to celestial coordinates +in the image 2 celestial coordinate system, and finally transform the +celestial coordinate system 2 coordinates to pixel coordinates in image 2, +all in one step. + +The \fIlogical coordinate system\fR is the pixel coordinate system of the +current image. This coordinate system is the one used by the image +input/output routines to access the image on disk. In the +logical coordinate system, +the coordinates of the pixel centers must lie within the following +range: 1.0 <= x[i] <= nx[i], where x[i] is the coordinate in dimension i, +nx[i] is the size of the image in dimension i, and the current maximum +number of image dimensions is 7. In the case of an image section, +the nx[i] refer to the dimensions of the section, not the dimensions +of the full image. + +The \fItv coordinate system\fR is the pixel coordinate system used by the +display servers XIMTOOL, SAOIMAGE, and IMTOOL. +For images which are not image sections +the tv and logical coordinate systems are identical. For images which are +image sections the tv and physical coordinate systems are identical if +the image has not undergone any prior linear transformations such as +axis flips, section copies, shifts, scale changes, rotations, etc. + +The \fIphysical coordinate system\fR is the coordinate system in which the +pixel coordinates of an object are invariant to successive linear +transformations +of the image. In this coordinate system, the pixel coordinates of an object +in an image remain the same, regardless of any section copies, shifts, +rotations, etc on the image. For example, an object with the +physical coordinates (x,y) in an image would still have physical +coordinates (x, y) in an image which is a section of the original image. + +The \fIworld coordinate system\fR is the default coordinate system for the +image. The default world coordinate system is the one named by the +environment variable "defwcs" if defined in the user environment (initially +it is undefined) and present in the image header; else it is the first +world coordinate system +defined for the image (the .imh and .hhh image format support only one wcs +but the .qp format can support more); else it is the physical coordinate +system. + +IF AN ERROR IS ENCOUNTERED WHEN DECODING THE INPUT OR OUTPUT WORLD COORDINATE +SYSTEMS, THEN AN ERROR FLAG IS PRINTED IN THE OUTPUT FILE AND ON THE STANDARD +OUTPUT IF \fIVERBOSE\fR IS YES, AND THE INPUT COORDINATES ARE COPIED TO THE +OUTPUT COORDINATES WITHOUT CHANGE. + +\fIIlngunits\fR, \fIilatunits\fR, \fIolngunits\fR, and \fIolatunits\fR +set the units of the input and output coordinate systems. +If the input or output system is the [logical/tv/physical] +system pixel units are assumed regardless of the values +of lngunits or latunits. The default lngunits and +latunits values are +hours and degrees for the equatorial celestial coordinate system and +degrees and degrees for the remaining celestial coordinate systems. + +The formats of the computed x/ra/longitude and y/dec/longitude coordinates +are specified with the \fIolngformat\fR and \fIolatformat\fR parameters. +The options are discussed in the formats section of the help page below. +If the output coordinate system is the [logical/tv/physical], +default formats of %10.3f and %10.3f are assumed regardless +of the values of olngunits and olatunits. Otherwise default formats +of %12.3h, %12.2h, and %g are assumed for output units of "hours", "degrees", +and "radians" respectively. + +.ih +USER COMMANDS + +If the input file is STDIN the user can type in the input data by hand and +set the input and output coordinate systems, the input and output coordinate +units, and the output coordinate format interactively. The available commands +are listed below. + +.nf + INTERACTIVE KEYSTROKE COMMANDS + +The following commands must be followed by a carriage return. + +? Print help +: Execute colon command +data Measure object +q Exit task + + + VALID DATA STRING + +x/ra/long y/dec/lat [pmra pmdec [parallax radial velocity]] + +... x/ra/long y/dec/lat must be in pixels or the input units +... pmra and pmdec must be in " / year +... parallax must be in " +... radial velocity must be in km / sec + + COLON COMMANDS + +The following commands must be followed by a carriage return. + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:iunits [string string] Show / set the input coordinate units +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT AND OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID INPUT AND OUTPUT CELESTIAL COORDINATE UNITS + AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7h +.fi + +.ih +IMAGE CURSOR COMMANDS + +In interactive image cursor mode the user can set the input and output +coordinate systems, the output coordinate units, and the output coordinate +formats. The available commands are listed below. + +.nf + INTERACTIVE KEYSTROKE COMMANDS + +? Print help +: Execute colon command +spbar Measure object +q Exit task + + + COLON COMMANDS + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT COORDINATE SYSTEMS + +image [tv] + + VALID OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID OUTPUT COORDINATE UNITS AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7g +.fi + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + + +.ih +REFERENCES + +Additional information on the IRAF world coordinate systems can be found in +the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + +.ih +EXAMPLES + +1. Precess the fk4 coordinates typed in by the user to the fk5 system with +and without the proper motion values. + +.nf + cl> skyctran STDIN STDOUT fk4 fk5 + + # Insystem: fk4 Coordinates: equatorial FK4 + # Equinox: B1950.000 Epoch: B1950.00000000 MJD: 33281.92346 + # Outsystem: fk5 Coordinates: equatorial FK5 + # Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 + + # Input file: STDIN Output file: STDOUT + + ... not including proper motion + 13:28:43.2 27:18:01.1 + 13:28:43.2 27:18:01.1 13:31:03.855 27:02:35.13 + + ... including proper motion + 13:28:43.2 27:18:01.1 .36 -0.16 + 13:28:43.2 27:18:01.1 .36 -0.16 13:31:05.215 27:02:27.37 + + ... change the output coordinate system to fk5 1975.0 and repeat + :os fk5 1975.0 + :os + + # Outsystem: fk5 1975.0 Coordinates: equatorial FK5 + # Equinox: J1975.000 Epoch: J1975.00000000 MJD: 42413.25000 + + 13:28:43.2 27:18:01.1 + 13:28:43.2 27:18:01.1 13:29:53.564 27:10:17.69 + + 13:28:43.2 27:18:01.1 .36 -0.16 + 13:28:43.2 27:18:01.1 .36 -0.16 13:29:54.244 27:10:13.80 + + ... type EOF to quit + +.fi + +2. Precess a list of RAS in hours and DECS in degrees in the FK5 system +equinox 1980.0 to equinox 2000.0 and write both the input coordinates and +the output coordinates in hours and degrees to the output file. + +.nf + cl> skyctran inlist outlist j1980.0 j2000.0 + + ... or equivalently ... + + cl> skyctran inlist outlist j1980.0 2000.0 + + ... or equivalently ... + + cl> skyctran inlist outlist "fk5 1980.0" fk5 +.fi + +Note that if the coordinate system, e.g. fk5, is not specified explicitly +then equinoxes < 1984 must be prefixed by J, or a Besselian rather than +a Julian epoch will be assumed. + +3. Repeat the previous example but replace the input coordinates with +the precessed coordinates in the output file. + +.nf + cl> skyctran inlist outlist j1980.0 j2000.0 transform+ +.fi + +4. Precess a list of RAS in hours and DECS in degrees in the FK4 system +equinox 1950.0 to equinox 1975.0 and write both the input coordinates and +the output coordinates in hours and degrees to the output file. The input +and output epochs of observation default to the respective equinox +values. + +.nf + cl> skyctran inlist outlist 1950.0 1975.0 + + ... or equivalently ... + + cl> skyctran inlist outlist b1950.0 b1975.0 + + ... or equivalently ... + + cl> skyctran inlist outlist fk4 b1975.0 + + ... or equivalently ... + + cl> skyctran inlist outlist fk4 "fk4 1975.0" +.fi + +5. Convert a list of RAS in hours and DECS in degrees in the FK4 system +equinox 1950.0 to RAS in hours and DECS in degrees in the FK5 system +equinox 2000.0, and replace the input coordinates with the +output coordinates in the output file. The Besselian epoch of the +observation is 1987.25. + +.nf + cl> skyctran inlist outlist "b1950.0 1987.25" j2000.0 \ + transform+ +.fi + +6. Convert a list of RAS in hours and DECS in degrees to RAS in degrees +and DECS in degrees, and replace the input coordinates with the output +coordinates in the output file. As the input and output coordinate systems +and equinoxes are the same no precession is performed. + +.nf + cl> skyctran inlist outlist 2000.0 2000.0 olngunits=degrees \ + transform+ +.fi + +7. Convert a list of RAS in hours and DECS in degrees in the FK4 +system, equinox 1950.0, epoch of observation 1987.24, to galactic +coordinates, and write both the input and output coordinate to the +output file. + +.nf + cl> skyctran inlist outlist "b1950.0 1987.25" galactic +.fi + +8. Convert a list of RAS in hours and DECS in degrees in the FK5 +system, equinox 2000.0, to ecliptic coordinates on Julian date +2449879.5, replacing the input coordinates with the converted +coordinates in the output file. + +.nf + cl> skyctran inlist outlist j2000 "ecliptic 2449879.5" \ + transform+ +.fi + +9. Display an image and use the cursor and image header coordinate +system, equatorial FK4, equinox 1950.0, epoch 1987.25 to print the pixel +and galactic coordinates of the marked objects on the image display. +Note that the test image dev$wpix has an incorrect value of EPOCH (0.0) that +would have confused skyctran and need to be changed. + +.nf + cl> imcopy dev$wpix wpix + cl> hedit wpix epoch 1950.0 + cl> display wpix 1 fi+ + cl> skyctran imcursor STDOUT wpix galactic +.fi + +10. Convert a list of RAS in hours and DECS in degrees measured in the +image created in example 9 to the FK5 equinox 2000.0 coordinate system. + +.nf + cl> skyctran inlist outlist "wpix world" j2000.0 + + ... or equivalently ... + + cl> skyctran inlist outlist "b1950.0 1987.25" j2000.0 +.fi + +11. Using an image whose header coordinate system is equatorial FK5 +equinox 2000.0 and a different image of the same region whose coordinate +system is galactic use the image display and cursor to create a list of +tie points in logical pixel coordinates that can be used as input to the +registration tasks geomap and geotran. Note that this example and examples +12 and 13 below will not work on iraf system earlier than 2.11 because galactic +image header coordinates are not fully supported. They will work +however on two images which have equatorial coordinates systems +which are precessed with respect to each other. + + +.nf + cl> display image1 + + ... this is the reference image + + cl> skyctran imcursor outlist image1 "image2 logical" + + ... mark many widely scattered points on the displayed + image image1 terminating the input list with + which is usually or +.fi + +12. Repeat example 11 but use a previously prepared list of image1 +logical pixel coordinates as input to the task. + +.nf + cl> skyctran inlist outlist "image1 logical"\ + "image2 logical" +.fi + +13. Repeat example 11 but have skyctran automatically generate a grid +of 100 tie points. + +.nf + cl> skyctran grid outlist "image1 logical"\ + "image2 logical" +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +setjd,precess,galactic,xray.xspatial.skypix,stsdas.toolbox.tools.tprecess +.endhelp diff --git a/pkg/images/imcoords/doc/starfind.hlp b/pkg/images/imcoords/doc/starfind.hlp new file mode 100644 index 00000000..9817735e --- /dev/null +++ b/pkg/images/imcoords/doc/starfind.hlp @@ -0,0 +1,304 @@ +.help starfind May97 images.imcoords +.ih +NAME +starfind -- automatically detect stellar objects in a list of images +.ih +USAGE +starfind image output hwhmpsf threshold +.ih +PARAMETERS +.ls image +The list of input images. The input images must be two-dimensional. +.le +.ls output +The list of output object files. The number of output files must equal the +number of input images. If output is "default", or "dir$default", or a +directory specification then a default name of the form +dir$root.extension.version is constructed, where dir$ is the directory name, +root is the root image name, extension is "obj", and version is the next +available version number. +.le +.ls hwhmpsf +The half-width half-maximum of the image PSF in pixels. +.le +.ls threshold +The detection threshold above local background in ADU. +.le +.ls datamin = INDEF, datamax = INDEF +The minimum and maximum good data values in ADU. Datamin and datamax +default to the constants -MAX_REAL and MAX_REAL respectively. +.le +.ls fradius = 2.5 (hwhmpsf) +The fitting radius in units of hwhmpsf. Fradius defines the size +of the Gaussian kernel used to compute the density enhancement image, and +the size of the image region used to do the moment analysis. +.le +.ls sepmin = 5.0 (hwhmpsf) +The minimum separation for detected objects in units of hwhmpsf. +.le +.ls npixmin = 5 +The minimum area of the detected objects in pixels. +.le +.ls maglo = INDEF, maghi = INDEF +The minimum and maximum magnitudes of the detected objects. Maglo and maghi +default to the constants -MAX_REAL and MAX_REAL respectively. +.le +.ls roundlo = 0.0, roundhi = 0.2 +The minimum and maximum ellipticity values of the detected objects, where +ellipticity is defined as 1 - b / a, and a and b are the semi-major and +semi-minor axis lengths respectively. +.le +.ls sharplo = 0.5, sharphi = 2.0 +The minimum and maximum sharpness values of the detected objects, where +sharpness is defined to be the ratio of the object size to the +hwhmpsf parameter value. +.le +.ls wcs = "" +The world coordinate system. The options are: +.ls " " +The world coordinate system is undefined. Only logical (pixel) coordinates +are printed. +.le +.ls logical +The world coordinate system is the same as the logical (pixel) coordinate +system, but two sets of identical logical (pixel) coordinates are printed. +.le +.ls physical +The world coordinate system is the same as the logical (pixel) coordinate +system of the parent image if any. +.le +.ls world +The world coordinate system of the image if any. +.le +.le +.ls wxformat = "", wyformat = "" +The output format for the x and y axis world coordinates. If wxformat and +wyformat are undefined then: 1) the value of the wcs format attribute is +used if the output wcs is "world" and the attribute is defined, 2) "%9.3f" +is used if the output wcs is "logical" or "physical", and "%11.8g" is used +if the output wcs is "world". If the input image is a sky projection image and +the x and y axes are ra and dec respectively, then the formats "%12.2H" and +"%12.1h" will print the world coordinates in hours and degrees respectively. +.le +.ls boundary = "nearest" +The boundary extension type. The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the other side of the image. +.le +.le +.ls constant = 0.0 +The constant for constant boundary extension. +.le +.ls nxblock = INDEF, nyblock = 256 +The working block size. If undefined nxblock and nyblock default +to the number of columns and rows in the input image respectively. +.le +.ls verbose = no +Print messages about the progress of the task ? +.le + +.ih +DESCRIPTION + +STARFIND searches the input images \fIimage\fR for local density maxima +with half-widths at half-maxima of ~ \fIhwhmpsf\fR and peak amplitudes +greater than ~ \fIthreshold\fR above the local background, and writes +the list of detected objects to \fIoutput\fR. + +STARFIND is a modified version of the DAOPHOT package DAOFIND algorithm. +However STARFIND is intended for use with the IMAGES package image matching +and image coordinates tasks and is therefore configured somewhat differently +than the version used in the photometry packages. + +.ih +ALGORITHMS + +STARFIND assumes that the point spread function can be approximated by a radial +Gaussian function whose sigma is 0.84932 * \fIhwhmpsf\fR pixels. STARFIND uses +this model to construct a convolution kernel which is truncated at +max (2.0, \fIfradius * hwhmpsf\fR) pixels and normalized to zero power. + +For each point in the image density enhancement values are computed by +convolving the input image with the radial Gaussian function. This operation +is mathematically equivalent to fitting the image data at each point, in the +least-squares sense, with a truncated, lowered, radial Gaussian function. +After the convolution each density enhancement value is an estimate of +the amplitude of the best fitting radial Gaussian function at that point. +If \fIdatamin\fR and \fIdatamax\fR are defined then bad data is ignored, +i.e. rejected from the fit, during the computation of the density enhancement +values. Out of bounds image pixels are evaluated using the boundary extension +algorithm parameters \fIboundary\fR and \fIconstant\fR. Out of +bounds density enhancement values are set to zero. + +After the convolution, STARFIND steps through the density enhancement +image searching for density enhancements greater then \fIthreshold\fR +and brighter than any density enhancements within a radius of +\fIsepmin * hwhmpsf\fR pixels. For each potential detection the +local background is estimated and used, along with the values of +\fIdatamin\fR and \fIdatamax\fR, to estimate the position (Xc and Yc), +size (Area and Hwhm), shape (E and Sharp), orientation (Pa), and +brightness (Mag) of each object using the second order moments analysis +shown below. + +.nf + I0 = sum (I) + N = sum (1.0) + if (N <= 0) + Sky = maxdata - maxden + else + Sky = I0 / N + + M0 = sum (I - Sky) + Mx = sum (X * (I - Sky)) + My = sum (Y * (I - Sky)) + + Xc = Mx / M0 + Xc = My / M0 + Mag = -2.5 * log10 (M0) + Area = N + + Mxx = sum ((X - Xc) * (X - Xc) * (I - Sky)) + Mxy = sum ((X - Xc) * (Y - Yc) * (I - Sky)) + Myy = sum ((Y - Yc) * (Y - Yc) * (I - Sky)) + + Hwhm = sqrt (log (2) * (Mxx + Myy)) + E = sqrt ((Mxx - Myy) ** 2 + 4 * Mxy ** 2) / (Mxx + Myy)) + Pa = 0.5 * atan (2 * Mxy / (Mxx - Myy)) +Sharp = Hmhw / Hwhmpsf +.fi + +The sums are computed using pixels which lie within \fIfradius * hwhmpsf\fR of +the maximum density enhancement, and whose values are within the good data +limits defined by \fIdatamin\fR and \fIdatamax\fR, and which are above the local +background estimate (Sky). + +Objects whose magnitude, roundness, and sharpness characteristics are outside +the values defined by \fImaglo\fR, \fImaghi\fR, \fIroundlo\fR, \fIroundhi\fR, +\fIsharplo\fR, and \fIsharphi\fR and whose total areas is less than +\fInpixmin\fR pixels are rejected from the list. + +If \fIwcs\fR parameter is defined, the world coordinates as well as +the pixel coordinates of the detected objects are computed and printed +using the formats defined by \fIwxformat\fR and \fIwyformat\fR. + +To minimize the memory requirements and increase efficiency, STARFIND +is configured to operate on data blocks that are \fInxblock * nyblock\fR +in size. To keep the image i/o operation to a minimum nxblock is set +to INDEF and defaults to the number of columns in the input image. +Setting both parameter to INDEF will force STARFIND to perform the +whole operation in memory. + +.ih +FORMATS + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) + absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +EXAMPLES + +1. Find stellar objects with peak values greater than 100 counts above +local background in the test image dev$wpix whose fwhm is ~2.5 pixels. + +.nf +cl> starfind dev$wpix default 1.25 100. +cl> display dev$wpix 1 fi+ +cl> tvmark 1 wpix.obj.1 col=204 +.fi + +2. Repeat the previous example but tell starfind to compute and print +world coordinates in hours and degrees as well as pixel coordinates. + +.nf +cl> starfind dev$wpix default 1.25 100. wcs=world wxf="%12.2H"\ + wyf="%12.1h" +cl> display dev$wpix 1 fi+ +cl> tvmark 1 wpix.obj.1 col=204 +.fi + +.ih +TIME REQUIREMENTS +Starfind requires approximately 8 CPU seconds to search a 512 by 512 +image using a 7 by 7 pixel convolution kernel (SPARCStation2). + +.ih +BUGS + +.ih +SEE ALSO +imcentroid, apphot.daofind, daophot.daofind +.endhelp diff --git a/pkg/images/imcoords/doc/wcsctran.hlp b/pkg/images/imcoords/doc/wcsctran.hlp new file mode 100644 index 00000000..c8ee4316 --- /dev/null +++ b/pkg/images/imcoords/doc/wcsctran.hlp @@ -0,0 +1,340 @@ +.help wcsctran May95 images.imcoords +.ih +NAME +wcsctran -- use the image WCS to transform between IRAF coordinate systems +.ih +USAGE +wcsctran input output image inwcs outwcs +.ih +PARAMETERS +.ls input +The list of input coordinate files. The number of input coordinate +files must be one or equal to the number of input images. Coordinates +may be entered by hand by setting input to "STDIN". +.le +.ls output +The list of output coordinate files. The number of coordinate files +must be one or equal to the number of input images. Results may be printed +on the terminal by setting output to "STDOUT". +.le +.ls image +The list of input images containing the WCS information. +.le +.ls inwcs, outwcs +The input and output coordinate systems. Coordinates in the input +file are assumed to be in the input system. Coordinates are written to +the output file in the output system. The options are: +.ls logical +Logical coordinates are pixel coordinates relative to the current +image. The logical coordinate system is the coordinate system used by +the image input/output routines to access the image data on disk. +.le +.ls tv +Tv coordinates are pixel coordinates used by the ximtool and saoimage +display servers. +Tv coordinates include the effects of any input image section, but +do not include the effects of previous linear transformations. +If the input image name does not include an image section, then tv coordinates +are identical to logical coordinates. If the input image name does include +a section, and the input image has not been linearly transformed or +copied from a parent image, tv coordinates are identical to physical +coordinates. +.le +.ls physical +Physical coordinates are pixel coordinates invariant with respect to linear +transformations of the physical image data. For example, if the current +image was created by extracting a section of another image, the physical +coordinates of an object in the current image will be equal to the physical +coordinates of the same object in the parent image, although the logical +coordinates will be different. +.le +.ls world +World coordinates are image coordinates in any units which are invariant with +respect to linear transformations of the physical image data. For example, +the ra and dec of an object will always be the same no matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +.le +.le +.ls columns = "1 2 3 4 5 6 7" +The list of columns separated by whitespace or commas in the input coordinate +file containing the coordinate values. +The number of specified columns must be greater than or equal to the +dimensionality of the input image. The coordinates are read in the +order they are specified in the columns parameter. +.le +.ls units = "" +The units of the input coordinate values, normally degrees for the sky +projection coordinate systems and angstroms for spectral coordinate +systems. +The options are: +.ls hours +Input coordinates specified in hours are converted to decimal degrees by +multiplying by 15.0. +.le +.ls native +The internal units of the wcs. No conversions on the input coordinates +are performed. +.le + +Units conversions are performed only if the input wcs is "world". +.le +.ls formats = "" +The format for the computed output coordinates. If the formats +parameter is undefined then: 1) the value of the wcs format attribute +is used if the output wcs is "world" and the attribute is defined, 2) +%g format is used with the precision set to the maximum of the precision of +the input coordinates and the value of the min_sigdigits parameter. +.le +.ls min_sigdigits = 7 +The minimum precision of the output coordinates if, the formats parameter +is undefined, and the output coordinate system is "world" but the wcs +format attribute is undefined. +.le +.ls verbose = yes +Print comment lines to the output file as the task executes. +.le + +.ih +DESCRIPTION + +WCSCTRAN transforms a list of coordinates, read from the input file +\fIinput\fR, from the coordinate system defined by \fIinwcs\fR to the +coordinate system defined by \fIoutwcs\fR using world coordinate system +information in the input image \fIimage\fR header and writes the results +to the output file \fIoutput\fR. + +The input coordinates are read from and written to the +columns in the input / output file specified by the \fIcolumns\fR parameter. +The units of the input coordinate units are assumed to be the internal +units of the coordinate system as defined in the image header, normally +degrees for sky projection coordinate systems and angstroms for +spectral coordinate systems. For convenience input coordinates in hours +are accepted and converted to decimal degrees if the \fIunits\fR parameter +is set appropriately. + +The format of the output units can be set using the +\fIformats\fR parameter. If the output formats are unspecified then the +output coordinates are written using, 1) the value of wcs format attribute if +outwcs = "world" and the attribute is defined, or, 2) the %g format and a +precision which is the maximum of the precision of the input coordinates +and the value of the \fImin_sigdigits\fR parameter. All remaining +fields in the input file are copied to the output file without modification. + +WCSCTRAN transforms coordinates from one builtin IRAF coordinate system +to another. The builtin coordinate systems are "logical", "physical", and +"world". For convenience WCSCTRAN also supports the "tv" coordinate system +which is not a builtin IRAF system, but is used by the display server tasks +XIMTOOL, SAOIMAGE, and IMTOOL. + +The \fIlogical coordinate system\fR is the pixel coordinate system of the +current image. This coordinate system is the one used by the image +input/output routines to access the image on disk. In the +logical coordinate system, +the coordinates of the pixel centers must lie within the following +range: 1.0 <= x[i] <= nx[i], where x[i] is the coordinate in dimension i, +nx[i] is the size of the image in dimension i, and the current maximum +number of image dimensions is 7. In the case of an image section, +the nx[i] refer to the dimensions of the section, not the dimensions +of the full image. + +The \fItv coordinate system\fR is the pixel coordinate system used by the +display servers XIMTOOL, SAOIMAGE, and IMTOOL. +For images which are not image sections +the tv and logical coordinate systems are identical. For images which are +image sections the tv and physical coordinate systems are identical if +the image has not undergone any prior linear transformations such as +axis flips, section copies, shifts, scale changes, rotations, etc. + +The \fIphysical coordinate system\fR is the coordinate system in which the +pixel coordinates of an object are invariant to successive linear +transformations +of the image. In this coordinate system, the pixel coordinates of an object +in an image remain the same, regardless of any section copies, shifts, +rotations, etc on the image. For example, an object with the +physical coordinates (x,y) in an image would still have physical +coordinates (x, y) in an image which is a section of the original image. + +The \fIworld coordinate system\fR is the default coordinate system for the +image. The default world coordinate system is the one named by the +environment variable "defwcs" if defined in the user environment (initially +it is undefined) and present in the image header; else it is the first +world coordinate system +defined for the image (the .imh and .hhh image format support only one wcs +but the .qp format can support more); else it is the physical coordinate +system. + +In most cases the number of input coordinates is equal to the number of +output coordinates, and both are equal to the dimensions of the input image. +In some cases however, the number of output coordinates may be greater or +less than the number of input coordinates. This situation occurs +if the input image has been dimensionally-reduced, i.e. is a section +of a higher-dimensioned parent image, and the input coordinate system +or the output coordinate system but not both is "logical" or "tv". +For example, if the input image is a 1D line extracted from a 2D parent +image with a sky projection world coordinate system, and the user +specifies a transformation from the "logical" to "world" systems, +only one input coordinate (column number) is required, but two output +coordinates (ra and dec) are produced. If the input and output coordinate +systems are reversed, then two input coordinates (ra and dec) are required, +but only one output coordinate (column number) is produced. If the number of +output coordinates is less than the number of input coordinates, the extra +input coordinate columns in the input file are set to INDEF in the output file. +If the number of output columns is greater than the number of input columns, +the extra coordinate columns are added to the end of the output line. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems can be found in +the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". Details of the FITS header world coordinate system interface can +be found in the document "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from our anonymous ftp +archive. + +.ih +EXAMPLES + +1. Find the pixel coordinates of a list of objects in an image, given a list +of their ras and decs in hh:mm:ss.s and dd:mm:ss format. Limit the precision +of the output coordinates to 3 decimal places. In this example, the input +ras and decs are assumed to be in columns 1 and 2 of the input coordinate +file, and the ras must be converted from hours to decimal degrees. + +.nf + im> wcsctran incoords outcoords image world logical units="h n" \ + formats="%8.3f %0.3f" +.fi + +2. Repeat the previous example using the same input coordinate list to +produce output coordinate lists for a list of input images. + +.nf + im> wcsctran incoords @outcoolist @imlist world logical units="h n" \ + formats="%8.3f %8.3f" +.fi + +3. Transform pixel coordinates in a photometry file to ra and dec +coordinates, writing the output coordinates in hh:mm:ss.ss and dd:mm:ss.s +format. The input pixel coordinates are stored in columns 3 and 4 of the +input coordinate file. + +.nf + im> wcsctran magfile omagfile image logical world col="3 4" \ + formats="%12.2H %12.1h" +.fi + +4. Given a set of pixel coordinates in the parent image, find the pixel +coordinates of the same objects in an image which is a shifted, rotated +and scaled version of the parent image. The input coordinate list +is created using the displayed parent image and the rimcursor task. +The output coordinate lists is marked on the displayed transformed +image using the tvmark task. + +.nf + im> display parent 1 fi+ + im> rimcursor > coolist + im> imlintran parent image 45.0 45.0 1.5 1.5 xin=256 yin=256 \ + xout=281 yout=263 + im> wcsctran coolist ocoolist image physical logical + im> display image 2 fi+ + im> tvmark 2 outcoolist +.fi + +.ih +TIME REQUIREMENTS + +.ih +BUGS + +.ih +SEE ALSO +wcsreset, wcsedit, rimcursor, listpixels, lintran + +.endhelp diff --git a/pkg/images/imcoords/doc/wcsedit.hlp b/pkg/images/imcoords/doc/wcsedit.hlp new file mode 100644 index 00000000..836add95 --- /dev/null +++ b/pkg/images/imcoords/doc/wcsedit.hlp @@ -0,0 +1,429 @@ +.help wcsedit Apr92 images.imcoords +.ih +NAME +wcsedit -- edit an image world coordinate system parameter +.ih +USAGE +wcsedit image parameter value axes1 +.ih +PARAMETERS +.ls image +The list of images for which the WCS is to be edited. Image sections are +ignored. If the image does not exist a data-less image header is first +created with the default WCS of dimensionality given by the "wcsdim" +parameter. +.le +.ls parameter +The WCS parameter to be edited. The WCS parameters recognized by +WCSEDIT are: 1) the FITS WCS +parameters crpix, crval, cd and, 2) the IRAF WCS parameters ltv, ltm, wtype, +axtype, units, label, and format. Only one WCS parameter may be edited at a +time. +.le +.ls value +The new parameter value. The numerical parameters crpix, crval, cd, ltv, and +ltm will not be updated if WCSEDIT is unable to decode the parameter value +into a legal floating point number. +.le +.ls axes1 +The list of principal axes for which \fIparameter\fR is to be edited. +Axes1 can +be entered as a list of numbers separated by commas, e.g. "1,2" or as a +range, e.g. "1-2". +.le +.ls axes2 +The list of dependent axes for which \fIparameter\fR is to be edited. +Axes2 can +be entered as a list of numbers separated by commas, e.g. "1,2" or as a +range, e.g. "1-2". The axes2 parameter is only required if +\fIparameter\fR is "cd" or "ltm". +.le +.ls wcs = "world" +The WCS to be edited. The options are: the builtin systems "world" or +"physical", or a named system, e.g. "image" or "multispec". The builtin system +"logical" may not be edited. +.ls world +If \fIwcs\fR is "world" the default WCS is edited. The default WCS +is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, +2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +.le +.ls physical +If \fIwcs\fR is "physical", WCS is the pixel coordinate system of +the original image, which may be different from the pixel coordinate system +of the current image, if the current image is the result of an +imcopy or other geometric transformation operation. In the "physical" +coordinate system the ltv, ltm and the axis attribute +parameters wtype, axtype, units, label, and format may be edited, but the FITS +parameters crval, crpix, and cd cannot. +.le +.ls name +A user supplied wcs name. +If the named WCS does not exist in the image, a new one of that +name initialized to the identity transform, will be opened for editing, and +the old WCS will be destroyed. This option should only be used for creating +a totally new FITS WCS. +.le +.le +.ls wcsdim = 2 +WCS dimensionality when creating a new data-less image header. +.le +.ls interactive = no +Edit the WCS interactively? +.le +.ls commands = "" +The interactive editing command prompt. +.le +.ls verbose = yes +Print messages about actions taken in interactive or non-interactive mode? +.le +.ls update = yes +Update the image header in non-interactive mode? A specific command exists +to do this in interactive mode. +.le + +.ih +DESCRIPTION +WCSEDIT modifies the WCS of an existing image or creates a data-less image +header of the dimensionality given by the \fIwcsdim\fR parameter. + +In non-interactive mode WCSEDIT replaces the current value of the WCS +parameter \fIparameter\fR with the new value \fIvalue\fR in the headers of +\fIimages\fR and prints a summary of the new WCS on the terminal. If +\fIverbose\fR is "no" the summary is not printed. If \fIverbose\fR is +"yes" and \fIupdate\fR is "no", the result of the editing operation +is printed on the terminal but the header is not modified. + +The WCS parameter \fIparameter\fR may be one of: crval, crpix, cd, ltv, ltm, +wtype, axtype, units, label, or format in either upper or lower case. +The WCS array parameters crpix, crval, ltv, wtype, axtype, units, label, +and format +may be edited for more than one axis at a time by setting \fIaxes1\fR to a +range of axes values. The WCS matrix parameters cd and ltm may be edited for +more than one axis at a time by setting both \fIaxes1\fR and \fIaxes2\fR to +a range of values. In this case, if no \fIaxes2\fR values are entered, +\fIaxes2\fR = "", the +diagonal elements of the cd and ltm matrices specified by \fIaxes1\fR are +edited. A single non-diagonal element of the cd or ltm matrices can be +edited by setting \fIaxis1\fR and \fIaxis2\fR to a single number. + +The user can create a new WCS from scratch by setting +\fIwcs\fR to a name different from the name of the WCS in the image header. +A new WCS with the same dimension as the image and initialized +to the identity transformation is presented to the user for editing. +IF THE USER UPDATES THE IMAGE HEADER AFTER EDITING THE NEW WCS, ALL +PREVIOUS WCS INFORMATION IS LOST. + +In interactive mode, WCSEDIT displays the current WCS +on the terminal if \fIverbose\fR = "yes", and prompts the user for +an editing command. The supported editing commands are shown below. + +.nf + BASIC COMMANDS + +? Print the WCSEDIT commands +show Print out the current WCS +update Quit WCSEDIT and update the image WCS +quit Quit WCSEDIT without updating the image WCS + + + PARAMETER DISPLAY AND EDITING COMMANDS + +crval [value axes1] Show/set the FITS crval parameter(s) +crpix [value axes1] Show/set the FITS crpix parameter(s) +cd [value axes1 [axes2]] Show/set the FITS cd parameter(s) +ltv [value axes1] Show/set the IRAF ltv parameter(s) +ltm [value axes1 [axes2]] Show/set the IRAF ltm parameter(s) +wtype [value axes1] Show/set the FITS/IRAF axes transform(s) +axtype [value axes1] Show/set the FITS/IRAF axis type(s) +units [value axes1] Show/set the IRAF units(s) +label [value axes1] Show/set the IRAF axes label(s) +format [value axes1] Show/set the IRAF axes coordinate format(s) +.fi + +.ih +THE WCS PARAMETERS + +Below is a list of the WCS parameters as they appear encoded in the in the +IRAF image header. Parameters marked with E can be edited directly with +WCSEDIT. Parameters marked with U should be updated automatically by WCSEDIT +if the proper conditions are met. The remaining parameters cannot be edited +with WCSEDIT. A brief description of the listed parameters is given below. +For a detailed description of the meaning of these parameters, the user +should consult the two documents listed in the REFERENCES section. + +.nf +WCSDIM WCS dimension (may differ from image) + +CTYPEn U coordinate type +CRPIXn E reference pixel +CRVALn E world coords of reference pixel +CDi_j E CD matrix + +CDELTn U CDi_i if CD matrix not used (input only) +CROTA2 U rotation angle if CD matrix not used + +LTVi E Lterm translation vector +LTMi_j E Lterm rotation matrix + +WATi_jjj U WCS attributes for axis I (wtype,axtype,units,label,format) +WAXMAPii WCS axis map +.fi + +The WCSDIM and WAXMAP parameters cannot be edited by WCSEDIT, unless a +new WCS is created in which case WCSDIM is set to +the dimension of the input image and the axis map is deleted. +The FITS parameters CRPIX, CRVAL, and CD +define the transformation between the world coordinate system and the pixel +coordinate system of the image and may be edited directly. The more general +FITS CD matrix notation supersedes the FITS CDELT/CROTA notation if both are +present on input, and is used by preference on output. The FITS parameter +CTYPE cannot be edited directly by WCSEDIT but is correctly updated on +output using the current values of the WCS parameters wtype and axtype +parameters, if there was a pre-existing FITS header in the image. On input +IRAF currently recognizes the following values of the FITS parameter CTYPE: +RA---TAN and DEC--TAN (the tangent plane sky projection), RA---SIN and +DEC--SIN (the sin sky projection), RA---ARC and DEC--ARC (the arc sky +projection), LINEAR, and MULTISPEC, from which it derives the correct values +for wtype and axtype. + +The LTV and LTM are IRAF parameters which define the transformation between +the +current image pixel coordinate system and the original pixel coordinate system, +if the current image was derived from a previous +image by a geometric transformation, e.g. IMCOPY or IMSHIFT. +Both parameters may be edited directly by WCSEDIT, but with the exception +of resetting the LTV vector to 0 and the LTM matrix to the identity +matrix it is not usually desirable to do so. The task WCSRESET can also +be used for this purpose. + +The WATi_jjj parameters are not directly accessible by WCSEDIT but the five +axis attributes which are encoded under these keywords (wtype, axtype, +units, label, and format) may be edited. +The IRAF WCS code currently +recognizes the following values for "wtype": "linear", "tan", "sin", +"arc", and "multispec". If "wtype" is not defined or cannot +be decoded by the WCS code "linear" is assumed. +Axtype should be "ra" or "dec" if wtype is one of the sky projections +"tan", "sin" or "arc", otherwise it should be undefined. +WCSEDIT will combine the values of "wtype" and "axtype" on output to +produce the correct value of the FITS keyword CTYPE. +The "label" and "units" parameter may be set to any string constant. +Format must be set to a legal IRAF format as described in the section +below. + +.ih +FORMATS +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". Details of the FITS header world coordinate system interface can +be found in the document "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from our anonymous ftp +archive. + +.ih +EXAMPLES + +1. Change the default output coordinate formats for an image with a defined +FITS tangent plane projection in its header, for the RA axis (axis 1), and the +DEC axis (axis 2) to %H and %h respectively. Then display the image and use +rimcursor to produce a coordinate list of objects whose coordinates are +printed as hh:mm:ss.s and dd:mm:ss.s respectively. + +.nf + cl> wcsedit image format %H 1 + cl> wcsedit image format %h 2 + cl> display image 1 + cl> rimcursor wcs=world > coordlist + ... mark the coordinates +.fi + +2. Change the default sky projection for an image with a defined tangent +plane projection to one with a sin projection. Note that wtype for both +axis1 and axis2 must be changed to "sin". Check the results first before +doing the actual update. + +.nf + cl> wcsedit image wtype sin 1-2 update- + cl> wcsedit image wtype sin 1-2 +.fi + + +3. Change the diagonal elements of the FITS cd matrix to 2.0. The off +diagonal elements are 0.0. This is equivalent to resetting the image scale. + +.nf + cl> wcsedit image cd 2.0 1-2 "" +.fi + +4. Set the value of the FITS cd matrix elements, cd[2,1] and cd[1,2] to 0.0. +This removes any rotation/skew from the WCS definition. + +.nf + cl> wcsedit image cd 0.0 2 1 + cl> wcsedit image cd 0.0 1 2 +.fi + +5. Change the FITS crval value for axis 2. + +.nf + cl> wcsedit image crval 47.85 2 +.fi + +6. Create a totally new WCS for an image, deleting the previous WCS +and set the diagonal elements of the cd matrix to 0.68. 0.68 is the +scale of the 36 inch telescope at KPNO. + +.nf + cl> wcsedit image cd 1.5 1-2 wcs="kpno9m" +.fi + +7. Interactively edit the WCS of an image. with an existing FITS header. + +.nf + cl> wcsedit image interactive+ + + ... summary of current WCS is printed on terminal + + wcsedit: ? + + ... user types in ? to see list of wcsedit commands + + wcsedit: cd 2.0 1-2 + + ... user changes the scale of the WCS + + wcsedit: format %0.3f 1-2 + + ... user changes format so the coordinates will be printed + out with 3 decimals of precision by any tasks which + can read the WCS format parameter such as rimcursor + and listpixels + + wcsedit: show + + ... user checks the new wcs + + wcsedit: update + + ... user quits editor and updates the image header +.fi + +8. Open and edit a new WCS for an image. Any pre-existing WCS will +be destroyed, assuming that the default wcs is not "newwcs". + +.nf + cl> wcsedit image wcs=newwcs intera+ + + wcsedit: .... + wcsedit: .... + + ... edit in the desired values + + wcsedit: update + + ... update the image header. +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +The IRAF WCS code supports the dimensional reduction of images, +for example creating an image with smaller dimensions than its parent, but +may not be fully compatible with FITS when this occurs. +In this case user may need to fix up an illegal or +incorrect WCS with HEDIT or HFIX bypassing the WCS code used by WCSEDIT. + +WCSEDIT does not permit the user to edit any parameters encoded in the +WATi_jjj keywords other than the five listed: wtype, axtype, units, label, +and format. For example WCSEDIT cannot be used to edit the "speci" parameters +used by the IRAF spectral reductions code "multispec" format. The spectral +reduction code itself should be used to do this, although hfix can +be used to fix a serious problem should it arise. +.ih +SEE ALSO +wcsreset,hedit,hfix +.endhelp diff --git a/pkg/images/imcoords/doc/wcsreset.hlp b/pkg/images/imcoords/doc/wcsreset.hlp new file mode 100644 index 00000000..401e0ae0 --- /dev/null +++ b/pkg/images/imcoords/doc/wcsreset.hlp @@ -0,0 +1,272 @@ +.help wcsreset Apr92 images.imcoords +.ih +NAME +wcsreset -- reset the image coordinate system +.ih +USAGE +wcsreset image wcs +.ih +PARAMETERS +.ls image +The list of images for which the coordinate system is to be reset. Image +sections are ignored. +.le +.ls wcs +The name of the coordinate system to be reset. The following systems are +pre-defined: +.ls physical +Reset the physical coordinate system to the logical coordinate system, but +leave the default world coordinate system unchanged. This operation removes +the history of past image operations such as imcopy, imshift, magnify, etc +from the definition of the physical coordinate system, but not from the +definition of the world coordinate system. +.le +.ls world +Reset the default world coordinate system to the logical coordinate system. +This operation removes all world coordinate system information from the +image header. +.le + +In addition to these two reserved world coordinate systems, the name of any +other defined world coordinate system, for example "multispec" may be given. +In this case WCSRESET resets the named coordinate system to the logical +coordinate system only if it is present in the image header. +.le +.ls verbose = yes +Print messages about actions taken by the task? +.le +.ih +DESCRIPTION + +WCSRESET resets the coordinate system \fIwcs\fR in the images specified by +\fIimage\fR to the logical coordinate system, and prints messages about the +actions taken if \fIverbose\fR = "yes". Since WCSRESET modifies the +image headers it should be used with caution. + +Logical coordinates are coordinates relative to the current image. The +logical coordinate system is the one used by the image input/output routines +to access the image on disk. In an image raster logical coordinate system, +the coordinates of the pixel centers must lie within the following +range: 1.0 <= x[i] <= nx[i], where x[i] is the coordinate in dimension i, +nx[i] is the size of the image in dimension i, and the current maximum +number of image dimensions is 7. In the case of an image section of an image +raster, the nx[i] refer to the dimensions of the section, not the dimensions +of the full image. The logical coordinate system cannot by definition be +reset. + +The physical coordinate system is the coordinate system in which the +coordinates of an object are invariant to successive linear transformations +of the image. In this coordinate system, the pixel coordinates of an object +in an image raster remain the same, regardless of any imcopy, imshift, +rotate, etc operations on the image. The most common reason for desiring to +reset the physical coordinate system to the logical coordinate system is to +make the new image independent of its history by removing the effects of +these linear transformation operations from its physical coordinate system. +Resetting the physical coordinate system to the logical coordinate system, +does not alter the default world coordinate system. If for example the input +image is a spectrum, with a defined dispersion solution, resetting the +physical coordinate system will not alter the dispersion solution. +Similarly if the input image is a direct CCD image with a defined sky +projection world coordinate system, resetting the physical coordinate system +will not alter the sky projection. + +The world coordinate system is the default coordinate system for the +image. The default world coordinate system is the one named by the +environment variable "defwcs" if defined in the user environment (initially +it is undefined) and present in the image header; else it is the first +world coordinate system +defined for the image (the .imh and .hhh image format support only one wcs +but the .qp format can support more); else it is the physical coordinate +system. Resetting the default coordinate system to the logical +coordinate system will destroy all coordinate information for that system, +for that image. + +If the user sets the parameter wcs to a specific system, for example +to "multispec", only images with the coordinate system "multispec" +will have their coordinate system reset. + +.ih +REFERENCES + +Detailed documentation for the IRAF world coordinate system interface MWCS +can be found in the file "iraf$sys/mwcs/MWCS.hlp". This file can be +formatted and printed with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | +lprint". Details of the FITS header world coordinate system interface can +be found in the document "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from our anonymous ftp +archive. + +.ih +EXAMPLES + +1. The user runs implot on a section of the spectrum outspec with the +wcs parameter set to "physical". + +.nf + implot outsec[30:50] wcs=physical +.fi + +To his/her surprise the range of the plot in x produced by implot is +[129,149] not [30:50] as expected. The user lists the image header with the +imheader task and sees the following. + +.nf + WCSDIM = 1 + CTYPE1 = 'LINEAR ' + CRVAL1 = 4953.94775390626 + CRPIX1 = -98. + CDELT1 = 0.0714096948504449 + CD1_1 = 0.0714096948504449 + WAT0_001= 'system=linear + WAT1_001= 'wtype=linear label=Wavelength units=Angstroms + LTV1 = -99. + LTM1_1 = 1. +.fi + +The standard FITS keywords CTYPE1, CRVAL1, CRPIX1, and CDELT1 are present. +The CD1_1 keyword is part of the new FITS CD matrix notation and in this +example duplicates the function of CDELT1. The remaining keywords WCSDIM, +WAT0_001, WAT1_001, LTV1, and LTM1_1 are IRAF specific keywords. The +user notes that the LTV1 keyword is -99. not 0. and suddenly remembers that +outspec was created by extracting a piece of a larger spectrum using the +imcopy task as shown below. + +.nf + cl> imcopy inspec[100:200] outspec +.fi + +The section [30:50] in outspec actually corresponds to the section [129:149] +in inspec and it is this coordinate system that implot is plotting when +wcs = "physical". The user decides has he/she does not want to know +about the pixel coordinate system of the original image and runs wcsreset +to reset the physical coordinate system to the logical coordinate system. + +.nf + wcsreset outspec physical +.fi + +The new header of outspec looks like the following. + +.nf + WCSDIM = 1 + CTYPE1 = 'LINEAR ' + CRVAL1 = 4953.94775390626 + CRPIX1 = -98. + CDELT1 = 0.0714096948504449 + CD1_1 = 0.0714096948504449 + WAT0_001= 'system=linear + WAT1_001= 'wtype=linear label=Wavelength units=Angstroms + LTM1_1 = 1. +.fi + +It is identical to the header listed above except that the +LTV1 keyword is not defined and is therefore 0. The user runs +implot with wcs = "physical" as before and sees a plot which extends +from 30 to 50 as expected. + +2. Reset the physical coordinate system of the direct CCD image skypix +which has a defined sky projection system. Skypix was created by +copying the central [129:384,129:384] of a 512 square image into a 256 +square image. + +The image header is the following. + +.nf + CRPIX1 = 129.75 + CRPIX2 = 130.93 + CRVAL1 = 201.94541667302 + CRVAL2 = 47.45444 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + CDELT1 = -2.1277777E-4 + CDELT2 = 2.1277777E-4 + WCSDIM = 2 + CD1_1 = -2.1277777000000E-4 + CD2_2 = 2.12777770000000E-4 + LTV1 = -128. + LTV2 = -128. + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=image + WAT1_001= 'wtype=tan axtype=ra + WAT2_001= 'wtype=tan axtype=dec +.fi + +The user runs implot on skypix wcs = "physical" + +.nf + implot skypix wcs=physical +.fi + +and sees a plot in x which extends from 129 to 384 which are the coordinates +of skypix in the original image. +The user resets the physical coordinate system to the logical coordinate +system. + +.nf + cl> wcsreset m51 physical +.fi + +The new header looks like the following. Note that the LTV1 and LTV2 keywords +have disappeared, they are 0. but everything else is the same. + +.nf + CRPIX1 = 129.75 + CRPIX2 = 130.93 + CRVAL1 = 201.94541667302 + CRVAL2 = 47.45444 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + CDELT1 = -2.1277777E-4 + CDELT2 = 2.1277777E-4 + WCSDIM = 2 + CD1_1 = -2.1277777000000E-4 + CD2_2 = 2.12777770000000E-4 + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=image + WAT1_001= 'wtype=tan axtype=ra + WAT2_001= 'wtype=tan axtype=dec +.fi + +When the user runs implot with wcs = "physical" he/she sees a plot which +extends from 1 to 256 as expected. + +3. Initialize the world coordinate system of the previous image. + +.nf + cl> wcsreset skypix world +.fi + +The header now looks like the following. + +.nf + WCSDIM = 2 + LTM1_1 = 1. + LTM2_2 = 1. + WAT0_001= 'system=physical + WAT1_001= 'wtype=linear + WAT2_001= 'wtype=linear +.fi + +The world system defaults to the physical coordinates system and the +physical coordinate system is identical to the logical coordinate system. +All coordinate information has been destroyed. + +4. Initialize the world coordinate system "spec1". If the default world +coordinate +system "spec1" cannot be found in the image header a warning message +will be issued and nothing will be changed. + +.nf + cl> wcsreset spectrum spec1 +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +rimcursor,listpixels,wcsedit,hedit,hfix +.endhelp diff --git a/pkg/images/imcoords/hpctran.par b/pkg/images/imcoords/hpctran.par new file mode 100644 index 00000000..7e58ee94 --- /dev/null +++ b/pkg/images/imcoords/hpctran.par @@ -0,0 +1,9 @@ +# HEALPIXWCS + +row,i,h,,,,Map row +lng,r,h,,,,Longitude +lat,r,h,,,,Latitude +nside,i,h,512,,,Resolution parameter +cunits,s,h,"degrees","hourdegree|degrees|radians",,Coordinate units +maptype,s,h,"nest","nest|ring",,Map type +direction,s,h,"ang2row","ang2row|row2ang",,Conversion direction diff --git a/pkg/images/imcoords/imcctran.par b/pkg/images/imcoords/imcctran.par new file mode 100644 index 00000000..13e9638e --- /dev/null +++ b/pkg/images/imcoords/imcctran.par @@ -0,0 +1,9 @@ +# Parameter file for the IMCCTRAN task + +image,f,a,,,,"List of input images" +outsystem,s,a,,,,"The new image coordinate system" +nx,i,h,10,,,"The coordinate grid size in x" +ny,i,h,10,,,"The coordinate grid size in y" +longpole,b,h,no,,,"Update longpole rather than the cd matrix where appropriate ?" +verbose,b,h,yes,,,"Print messages about actions taken ?" +update,b,h,yes,,,"Update the image header ?" diff --git a/pkg/images/imcoords/imcoords.cl b/pkg/images/imcoords/imcoords.cl new file mode 100644 index 00000000..5f756aee --- /dev/null +++ b/pkg/images/imcoords/imcoords.cl @@ -0,0 +1,27 @@ +#{ IMCOORDS -- The Image Coordinates Package. + +set imcoords = "images$imcoords/" + +package imcoords + +# Tasks. + +task ccfind, + ccget, + ccmap, + ccsetwcs, + ccstd, + cctran, + ccxymatch, + hpctran, + imcctran, + skyctran, + starfind, + wcsctran, + wcsedit, + wcsreset = "imcoords$x_images.e" + +task mkcwcs = "imcoords$src/mkcwcs.cl" +task mkcwwcs = "imcoords$src/mkcwwcs.cl" + +clbye() diff --git a/pkg/images/imcoords/imcoords.hd b/pkg/images/imcoords/imcoords.hd new file mode 100644 index 00000000..1f60d023 --- /dev/null +++ b/pkg/images/imcoords/imcoords.hd @@ -0,0 +1,23 @@ +# Help directory for the IMCOORDS package + +$doc = "images$imcoords/doc/" +$src = "images$imcoords/src/" + +ccfind hlp=doc$ccfind.hlp, src=src$t_ccfind.x +ccget hlp=doc$ccget.hlp, src=src$t_ccget.x +ccmap hlp=doc$ccmap.hlp, src=src$t_ccmap.x +ccsetwcs hlp=doc$ccsetwcs.hlp, src=src$t_ccsetwcs.x +ccstd hlp=doc$ccstd.hlp, src=src$t_ccstd.x +cctran hlp=doc$cctran.hlp, src=src$t_cctran.x +ccxymatch hlp=doc$ccxymatch.hlp, src=src$t_ccxymatch.x +hpctran hlp=doc$hpctran.hlp, src=src$t_hpctran.x +imcctran hlp=doc$imcctran.hlp, src=src$t_imcctran.x +mkcwcs hlp=doc$mkcwcs.hlp, src=src$mkcwcs.cl +mkcwwcs hlp=doc$mkcwwcs.hlp, src=src$mkcwwcs.cl +skyctran hlp=doc$skyctran.hlp, src=src$t_skyctran.x +starfind hlp=doc$starfind.hlp, src=src$t_starfind.x +wcsctran hlp=doc$wcsctran.hlp, src=src$t_wcsctran.x +wcsedit hlp=doc$wcsedit.hlp, src=src$t_wcsedit.x +wcsreset hlp=doc$wcsreset.hlp, src=src$t_wcsreset.x +revisions sys=Revisions + diff --git a/pkg/images/imcoords/imcoords.men b/pkg/images/imcoords/imcoords.men new file mode 100644 index 00000000..3a30ac9c --- /dev/null +++ b/pkg/images/imcoords/imcoords.men @@ -0,0 +1,16 @@ + ccfind - Find catalog sources in an image + ccget - Extract objects from a text file catalog + ccmap - Compute image plate solutions using matched coordinate lists + ccsetwcs - Create an image celestial wcs from the ccmap plate solution + ccstd - Transform to and from standard astrometric coordinates + cctran - Transform coordinate lists using the ccmap plate solution + ccxymatch - Match celestial and pixel coordinate lists + hpctran - Convert between HEALPix row and spherical coordinate + imcctran - Transform image header from one celestial wcs to another + mkcwcs - Make or update a simple celestial wcs + mkcwwcs - Make or update a simple celestial/wavelength 3D wcs + skyctran - Transform coordinates from one celestial wcs to another + starfind - Automatically detect stellar objects in a list of images + wcsctran - Transform coordinates from one iraf image wcs to another + wcsedit - Edit an image wcs parameter + wcsreset - Reset the specified image wcs diff --git a/pkg/images/imcoords/imcoords.par b/pkg/images/imcoords/imcoords.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/imcoords/imcoords.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/imcoords/mkpkg b/pkg/images/imcoords/mkpkg new file mode 100644 index 00000000..e1cb9e6a --- /dev/null +++ b/pkg/images/imcoords/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMCOORDS Package + +libpkg.a: + @src + ; diff --git a/pkg/images/imcoords/skyctran.par b/pkg/images/imcoords/skyctran.par new file mode 100644 index 00000000..d5658ffe --- /dev/null +++ b/pkg/images/imcoords/skyctran.par @@ -0,0 +1,29 @@ +# Parameter file for the SKYCOORDS task. + +input,s,a,"STDIN",,,The input coordinate files(s) +output,s,a,"STDOUT",,,The output coordinate file(s) +insystem,s,a,"fk4",,,The input coordinate system +outsystem,s,a,"fk5",,,The output coordinate system +transform,s,h,no,,,Transform the input coordinate file ? +lngcolumn,i,h,1,,,The input file column containing the x/ra/longitude +latcolumn,i,h,2,,,The input file column containing the y/dec/latitude +plngcolumn,i,h,INDEF,,,The input file column containing the x/ra/longitude pm +platcolumn,i,h,INDEF,,,The input file column containing the y/dec/latitude pm +pxcolumn,i,h,INDEF,,,The input file column contain the parallax +rvcolumn,i,h,INDEF,,,The input file column contain the radial velocity +ilngmin,r,h,INDEF,,,The input grid x/ra/longitude minimum +ilngmax,r,h,INDEF,,,The input grid x/ra/longitude maximum +ilatmin,r,h,INDEF,,,The input grid y/dec/latitude minimum +ilatmax,r,h,INDEF,,,The input grid y/dec/latitude maximum +nilng,i,h,10,1,,Number of grid points in x/ra/longitude +nilat,i,h,10,1,,Number of grid points in y/dec/latitude +ilngunits,s,h,"",,,The input ra/longitude units +ilatunits,s,h,"",,,The input dec/latitude units +ilngformat,s,h,"",,,The input grid x/ra/longitude format +ilatformat,s,h,"",,,The input grid y/dec/latitude format +olngunits,s,h,"",,,The output ra/longitude units +olatunits,s,h,"",,,The output dec/latitude units +olngformat,s,h,"",,,The output x/ra/longitude format +olatformat,s,h,"",,,The output y/dec/latitude format +icommands,*imcur,h,"",,,The image display cursor +verbose,b,h,yes,,,Print messages about actions taken by the task ? diff --git a/pkg/images/imcoords/src/ccfunc.x b/pkg/images/imcoords/src/ccfunc.x new file mode 100644 index 00000000..9f60498a --- /dev/null +++ b/pkg/images/imcoords/src/ccfunc.x @@ -0,0 +1,639 @@ +include +include +include +include +include + + +# CC_RPROJ -- Read the projection parameters from a file into an IRAF string +# containing the projection type followed by an MWCS WAT string, e.g +# "zpn projp1=value projp2=value" . + +int procedure cc_rdproj (fd, projstr, maxch) + +int fd #I the input file containing the projection parameters +char projstr[ARB] #O the output projection parameters string +int maxch #I the maximum size of the output projection string + +int projection, op +pointer sp, keyword, value, param +int fscan(), nscan(), strdic(), gstrcpy() + +begin + projstr[1] = EOS + if (fscan (fd) == EOF) + return (0) + + call smark (sp) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + + call gargwrd (Memc[keyword], SZ_FNAME) + projection = strdic (Memc[keyword], Memc[keyword], SZ_FNAME, + WTYPE_LIST) + if (projection <= 0 || projection == WTYPE_LIN || nscan() == 0) { + call sfree (sp) + return (0) + } + + # Copy the projection function into the projection string. + op = 1 + op = op + gstrcpy (Memc[keyword], projstr[op], maxch) + + # Copy the keyword value pairs into the projection string. + while (fscan(fd) != EOF) { + call gargwrd (Memc[keyword], SZ_FNAME) + call gargwrd (Memc[value], SZ_FNAME) + if (nscan() != 2) + next + call sprintf (Memc[param], SZ_FNAME, " %s = %s") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + op = op + gstrcpy (Memc[param], projstr[op], maxch - op + 1) + } + + call sfree (sp) + + return (projection) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# CC_WCSIM -- Update the image world coordinate system. + +procedure cc_wcsim (im, coo, projection, lngref, latref, sx1, sy1, transpose) + +pointer im #I the pointer to the input image +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. +pointer sx1, sy1 #I pointer to linear surfaces +bool transpose #I transpose the wcs + +int ndim, naxes, ax1, ax2, axmap, wtype +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, str, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +int mw_stati(), sk_stati(), strdic() +pointer mw_openim() + +begin + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + + # Compute the original logical to world transformation. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + + # Get the axis map. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the system. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call mw_swtype (mw, Memi[axes], ndim, projection, + "axis 1: axtype=ra axis 2: axtype=dec") + } + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax1-1] = tlatref + Memd[w+ax2-1] = tlngref + } + + + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[nr+ax1-1] = xpix + Memd[nr+ax2-1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = a / 3600.0d0 + NEWCD(ax1,ax2) = c / 3600.0d0 + NEWCD(ax2,ax1) = b / 3600.0d0 + NEWCD(ax2,ax2) = d / 3600.0d0 + } else { + NEWCD(ax1,ax1) = c / 3600.0d0 + NEWCD(ax1,ax2) = a / 3600.0d0 + NEWCD(ax2,ax1) = d / 3600.0d0 + NEWCD(ax2,ax2) = b / 3600.0d0 + } + + # Reset the axis map. + call mw_seti (mw, MW_USEAXMAP, axmap) + + # Recompute and store the new wcs if update is enabled. + call mw_saxmap (mw, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[cd], ndim) + } + + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mw, im) + call mw_saveim (mw, im) + call mw_close (mw) + + # Force the CDELT keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (projection, Memc[str], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. This will be unecessary when wcs is updated to deal + # with non-quoted and / or non left-justified CTYPE keywords. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_NWCSIM -- Update the image world coordinate system. + +procedure cc_nwcsim (im, coo, projection, lngref, latref, sx1, sy1, sx2, sy2, + transpose) + +pointer im #I the pointer to the input image +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool transpose #I transpose the wcs + +int l, i, ndim, naxes, ax1, ax2, axmap, wtype, szatstr +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +pointer projstr, projpars, wpars, mwnew, atstr +bool streq() +int mw_stati(), sk_stati(), strdic(), strlen(), itoc() +pointer mw_openim(), mw_open() +errchk mw_gwattrs(), mw_newsystem() + +begin + # Open the image wcs and determine its size. + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + + # Allocate working memory for the wcs attributes, vectors, and + # matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + + # Open the new wcs and set the system type. + mwnew = mw_open (NULL, ndim) + call mw_gsystem (mw, Memc[projstr], SZ_FNAME) + iferr { + call mw_newsystem (mw, "image", ndim) + } then { + call mw_newsystem (mwnew, Memc[projstr], ndim) + } else { + call mw_newsystem (mwnew, "image", ndim) + } + + # Set the LTERM. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwnew, Memd[ltm], Memd[ltv], ndim) + + # Store the old axis map for later use. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + + # Get the celestial coordinate axes list. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the axes and projection type for the celestial coordinate + # axes. Don't worry about the fact that the axes may in fact be + # glon and glat, elon and elat, or slon and slat, instead of + # ra and dec. This will be fixed up later. + if (projection[1] == EOS) { + call mw_swtype (mwnew, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + if (streq (Memc[projstr], "tnx") && sx2 == NULL && sy2 == NULL) + call strcpy ("tan", Memc[projstr], SZ_FNAME) + call mw_swtype (mwnew, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Copy the attributes of the remaining axes to the new wcs. + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + do l = 1, ndim { + if (l == ax1 || l == ax2) + next + iferr { + call mw_gwattrs (mw, l, "wtype", Memc[projpars], SZ_LINE) + } then { + call mw_swtype (mwnew, l, 1, "linear", "") + } else { + call mw_swtype (mwnew, l, 1, Memc[projpars], "") + } + for (i = 1; ; i = i + 1) { + if (itoc (i, Memc[projpars], SZ_LINE) <= 0) + Memc[projpars] = EOS + repeat { + iferr (call mw_gwattrs (mw, l, Memc[projpars], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen(Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwnew, l, Memc[projpars], Memc[atstr]) + } + } + call mfree (atstr, TY_CHAR) + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax1-1] = tlatref + Memd[w+ax2-1] = tlngref + } + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[nr+ax1-1] = xpix + Memd[nr+ax2-1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = a / 3600.0d0 + NEWCD(ax1,ax2) = c / 3600.0d0 + NEWCD(ax2,ax1) = b / 3600.0d0 + NEWCD(ax2,ax2) = d / 3600.0d0 + } else { + NEWCD(ax1,ax1) = c / 3600.0d0 + NEWCD(ax1,ax2) = a / 3600.0d0 + NEWCD(ax2,ax1) = d / 3600.0d0 + NEWCD(ax2,ax2) = b / 3600.0d0 + } + + # Recompute and store the new wcs. + call mw_saxmap (mwnew, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) + } + + # Add the second order terms in the form of the wcs attributes + # lngcor and latcor. These are not FITS standard and can currently + # be understood only by IRAF. + if ((streq(Memc[projstr], "zpx") || streq (Memc[projstr], "tnx")) && + (sx2 != NULL || sy2 != NULL)) { + if (! transpose) + call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", + "latcor", ax1, ax2) + else + call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", + "latcor", ax2, ax1) + } + + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mwnew, im) + call mw_saveim (mwnew, im) + call mw_close (mwnew) + call mw_close (mw) + + # Force the CTYPE keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_WCSCOR -- Reformulate the higher order surface fit into a correction +# term in degrees that can be written into the header as a wcs attribute. +# This attribute will be written as string containing the surface definition. + +procedure cc_wcscor (im, mw, sx1, sx2, sy1, sy2, xiname, etaname, xiaxis, + etaaxis) + +pointer im #I pointer to the input image +pointer mw #I pointer to the wcs structure +pointer sx1, sx2 #I pointer to the linear and distortion xi surfaces +pointer sy1, sy2 #I pointer to the linear and distortion eta surfaces +char xiname[ARB] #I the wcs xi correction attribute name +char etaname[ARB] #I the wcs eta correction attribute name +int xiaxis #I the xi axis number +int etaaxis #I the eta axis number + +int i, j, function, xxorder, xyorder, xxterms, yxorder, yyorder, yxterms +int nx, ny, npix, ier +double sxmin, sxmax, symin, symax, ratio, x, y, xstep, ystep, ximin, ximax +double etamin, etamax +pointer sp, xpix, ypix, xilin, etalin, dxi, deta, wgt, nsx2, nsy2 +int dgsgeti() +double dgsgetd() +begin + if (sx2 == NULL && sy2 == NULL) + return + if (dgsgeti (sx1, GSTYPE) != dgsgeti (sy1, GSTYPE)) + return + + # Get the function, xmin, xmax, ymin, and ymax parameters for the + # surfaces. + function = min (dgsgeti (sx1, GSTYPE), dgsgeti (sy1, GSTYPE)) + sxmin = max (dgsgetd (sx1, GSXMIN), dgsgetd (sy1, GSXMIN)) + sxmax = min (dgsgetd (sx1, GSXMAX), dgsgetd (sy1, GSXMAX)) + symin = max (dgsgetd (sx1, GSYMIN), dgsgetd (sy1, GSYMIN)) + symax = min (dgsgetd (sx1, GSYMAX), dgsgetd (sy1, GSYMAX)) + + # Get the order and cross-terms parameters from the higher order + # functions. + if (sx2 != NULL) { + xxorder = dgsgeti (sx2, GSXORDER) + xyorder = dgsgeti (sx2, GSYORDER) + xxterms = dgsgeti (sx2, GSXTERMS) + } else { + xxorder = dgsgeti (sx1, GSXORDER) + xyorder = dgsgeti (sx1, GSYORDER) + xxterms = dgsgeti (sx1, GSXTERMS) + } + if (sy2 != NULL) { + yxorder = dgsgeti (sy2, GSXORDER) + yyorder = dgsgeti (sy2, GSYORDER) + yxterms = dgsgeti (sy2, GSXTERMS) + } else { + yxorder = dgsgeti (sy1, GSXORDER) + yyorder = dgsgeti (sy1, GSYORDER) + yxterms = dgsgeti (sy1, GSXTERMS) + } + + # Choose a reasonable coordinate grid size based on the x and y order + # of the fit and the number of rows and columns in the image. + ratio = double (IM_LEN(im,2)) / double (IM_LEN(im,1)) + nx = max (xxorder + 3, yxorder + 3, 10) + ny = max (yyorder + 3, xyorder + 3, nint (ratio * 10)) + npix = nx * ny + + # Allocate some working space. + call smark (sp) + call salloc (xpix, npix, TY_DOUBLE) + call salloc (ypix, npix, TY_DOUBLE) + call salloc (xilin, npix, TY_DOUBLE) + call salloc (etalin, npix, TY_DOUBLE) + call salloc (dxi, npix, TY_DOUBLE) + call salloc (deta, npix, TY_DOUBLE) + call salloc (wgt, npix, TY_DOUBLE) + + # Compute the grid of x and y points. + xstep = (sxmax - sxmin) / (nx - 1) + ystep = (symax - symin) / (ny - 1) + y = symin + npix = 0 + do j = 1, ny { + x = sxmin + do i = 1, nx { + Memd[xpix+npix] = x + Memd[ypix+npix] = y + x = x + xstep + npix = npix + 1 + } + y = y + ystep + } + + + # Compute the weights + call amovkd (1.0d0, Memd[wgt], npix) + + # Evalute the linear surfaces and convert the results from arcseconds + # to degrees. + call dgsvector (sx1, Memd[xpix], Memd[ypix], Memd[xilin], npix) + call adivkd (Memd[xilin], 3600.0d0, Memd[xilin], npix) + call alimd (Memd[xilin], npix, ximin, ximax) + call dgsvector (sy1, Memd[xpix], Memd[ypix], Memd[etalin], npix) + call adivkd (Memd[etalin], 3600.0d0, Memd[etalin], npix) + call alimd (Memd[etalin], npix, etamin, etamax) + + # Evalute the distortion surfaces, convert the results from arcseconds + # to degrees, and compute new distortion surfaces. + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xpix], Memd[ypix], Memd[dxi], npix) + call adivkd (Memd[dxi], 3600.0d0, Memd[dxi], npix) + call dgsinit (nsx2, function, xxorder, xyorder, xxterms, + ximin, ximax, etamin, etamax) + call dgsfit (nsx2, Memd[xilin], Memd[etalin], Memd[dxi], + Memd[wgt], npix, WTS_UNIFORM, ier) + call cc_gsencode (mw, nsx2, xiname, xiaxis) + } else + nsx2 = NULL + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xpix], Memd[ypix], Memd[deta], npix) + call adivkd (Memd[deta], 3600.0d0, Memd[deta], npix) + call dgsinit (nsy2, function, yxorder, yyorder, yxterms, + ximin, ximax, etamin, etamax) + call dgsfit (nsy2, Memd[xilin], Memd[etalin], Memd[deta], + Memd[wgt], npix, WTS_UNIFORM, ier) + call cc_gsencode (mw, nsy2, etaname, etaaxis) + } else + nsy2 = NULL + + # Store the string in the mcs structure in the format of a wcs + # attribute. + + # Free the new surfaces. + if (nsx2 != NULL) + call dgsfree (nsx2) + if (nsy2 != NULL) + call dgsfree (nsy2) + + call sfree (sp) +end + + +# CC_GSENCODE -- Encode the surface in an mwcs attribute. + +procedure cc_gsencode (mw, gs, atname, axis) + +pointer mw #I pointer to the mwcs structure +pointer gs #I pointer to the surface to be encoded +char atname[ARB] #I attribute name for the encoded surface +int axis #I axis for which the encode surface is encoded + +int i, op, nsave, szatstr, szpar +pointer sp, coeff, par, atstr +int dgsgeti(), strlen(), gstrcpy() + +begin + nsave = dgsgeti (gs, GSNSAVE) + call smark (sp) + call salloc (coeff, nsave, TY_DOUBLE) + call salloc (par, SZ_LINE, TY_CHAR) + call dgssave (gs, Memd[coeff]) + + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + op = 0 + do i = 1, nsave { + call sprintf (Memc[par], SZ_LINE, "%g ") + call pargd (Memd[coeff+i-1]) + szpar = strlen (Memc[par]) + if (szpar > (szatstr - op)) { + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + op = op + gstrcpy (Memc[par], Memc[atstr+op], SZ_LINE) + + } + + call mw_swattrs (mw, axis, atname, Memc[atstr]) + call mfree (atstr, TY_CHAR) + call sfree (sp) +end + + + diff --git a/pkg/images/imcoords/src/ccstd.x b/pkg/images/imcoords/src/ccstd.x new file mode 100644 index 00000000..319d18ba --- /dev/null +++ b/pkg/images/imcoords/src/ccstd.x @@ -0,0 +1,252 @@ +include +include +include +include + +# CC_INIT_STD -- Get the parameter values relevant to the transformation from +# the cl or the database file. +# +procedure cc_init_std (dt, record, geometry, lngunits, latunits, sx1, + sy1, sx2, sy2, mw, coo) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the coordinate structure + +double lngref, latref +int recstat, proj +pointer sp, projstr, projpars +int cc_dtrecord(), strdic() +pointer cc_celwcs() + +begin + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + + if (dt == NULL) { + + call cc_rinit (lngunits, latunits, sx1, sy1, mw, coo) + sx2 = NULL + sy2 = NULL + + } else { + + recstat = cc_dtrecord (dt, record, geometry, coo, Memc[projpars], + lngref, latref, sx1, sy1, sx2, sy2) + if (recstat == ERR) { + coo = NULL + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + mw = NULL + } else { + call sscan (Memc[projpars]) + call gargwrd (Memc[projstr], SZ_FNAME) + proj = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projpars] = EOS + mw = cc_celwcs (coo, Memc[projpars], lngref, latref) + } + } + + call sfree (sp) +end + + +# CC_FREE_STD -- Free the previously defined transformation. + +procedure cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + +pointer sx1, sy1 #U pointers to the linear x and y surfaces +pointer sx2, sy2 #U pointers to the x and y distortion surfaces +pointer mw #U pointer to the mwcs structure +pointer coo #U pointer to the celestial coordinate structure + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) +end + + +# CC_RINIT -- Compute the required wcs structure from the input parameters. + +procedure cc_rinit (lngunits, latunits, sx1, sy1, mw, coo) + +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1 #O pointer to the linear x coordinate surface +pointer sy1 #O pointer to the linear y coordinate surface +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the celestial coordinate structure + +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +int coostat, proj, tlngunits, tlatunits, pfd +pointer sp, projstr +double clgetd() +double dgseval() +int sk_decwcs(), sk_stati(), strdic(), open() +pointer cc_celwcs(), cc_rdproj() +errchk open() + +begin + # Allocate some workin space. + call smark (sp) + call salloc (projstr, SZ_LINE, TY_CHAR) + + # Get the reference point pixel coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = 0.0d0 + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = 0.0d0 + + # Get the scale factors. + xscale = clgetd ("xmag") + if (IS_INDEFD(xscale)) + xscale = 1.0d0 + yscale = clgetd ("ymag") + if (IS_INDEFD(yscale)) + yscale = 1.0d0 + + # Get the rotation angles. + xrot = clgetd ("xrotation") + if (IS_INDEFD(xrot)) + xrot = 0.0d0 + xrot = -DEGTORAD(xrot) + yrot = clgetd ("yrotation") + if (IS_INDEFD(yrot)) + yrot = 0.0d0 + yrot = -DEGTORAD(yrot) + + # Initialize the linear part of the solution. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, NO, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, NO, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call geo_rotmagd (sx1, sy1, xscale, yscale, xrot, yrot) + call geo_xyshiftd (sx1, sy1, -dgseval (sx1, xref, yref), + -dgseval (sy1, xref, yref)) + + lngref = clgetd ("lngref") + if (IS_INDEFD(lngref)) + lngref = 0.0d0 + latref = clgetd ("latref") + if (IS_INDEFD(latref)) + latref = 0.0d0 + + coostat = sk_decwcs ("j2000", mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + } + if (lngunits <= 0) + tlngunits = sk_stati (coo, S_NLNGUNITS) + else + tlngunits = lngunits + call sk_seti (coo, S_NLNGUNITS, tlngunits) + if (latunits <= 0) + tlatunits = sk_stati (coo, S_NLATUNITS) + else + tlatunits = latunits + call sk_seti (coo, S_NLATUNITS, tlatunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + mw = cc_celwcs (coo, Memc[projstr], lngref, latref) + + call sfree (sp) +end + + +define MAX_NITER 20 + +# CC_DO_STD -- Transform the coordinates using the full transformation +# computed by CCMAP. + +procedure cc_do_std (x, y, xt, yt, sx1, sy1, sx2, sy2, forward) + +double x, y #I initial positions +double xt, yt #O transformed positions +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool forward #I forward transform + +double f, fx, fy, g, gx, gy, denom, dx, dy +int niter +pointer newsx, newsy +double dgseval() + +begin + + if (forward) { + + xt = dgseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + dgseval (sx2, x, y) + yt = dgseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + dgseval (sy2, x, y) + + } else { + + xt = x / 1.0 + yt = y / 1.0 + + call dgsadd (sx1, sx2, newsx) + call dgsadd (sy1, sy2, newsy) + niter = 0 + repeat { + + f = dgseval (newsx, xt, yt) - x + call dgsder (newsx, xt, yt, fx, 1, 1, 0) + call dgsder (newsx, xt, yt, fy, 1, 0, 1) + + g = dgseval (newsy, xt, yt) - y + call dgsder (newsy, xt, yt, gx, 1, 1, 0) + call dgsder (newsy, xt, yt, gy, 1, 0, 1) + + denom = fx * gy - fy * gx + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + xt = xt + dx + yt = yt + dy + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 1.0e-5) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + call dgsfree (newsx) + call dgsfree (newsy) + } +end diff --git a/pkg/images/imcoords/src/ccxytran.x b/pkg/images/imcoords/src/ccxytran.x new file mode 100644 index 00000000..537c28f6 --- /dev/null +++ b/pkg/images/imcoords/src/ccxytran.x @@ -0,0 +1,740 @@ +include +include + +# Define the transform geometries +define GEO_LINEAR 1 +define GEO_DISTORTION 2 +define GEO_GEOMETRIC 3 + +# CC_INIT_TRANSFORM -- Get the parameter values relevant to the +# transformation from the cl. + +procedure cc_init_transform (dt, record, geometry, lngunits, latunits, sx1, + sy1, sx2, sy2, mw, coo) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the coordinate structure + +double lngref, latref +int recstat, proj +pointer sp, projstr, projpars +int cc_dtrecord(), strdic() +pointer cc_geowcs(), cc_celwcs() + +begin + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + + if (dt == NULL) { + + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + call cc_linit (lngunits, latunits, mw, coo) + + } else { + + recstat = cc_dtrecord (dt, record, geometry, coo, Memc[projpars], + lngref, latref, sx1, sy1, sx2, sy2) + if (recstat == ERR) { + coo = NULL + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + mw = NULL + } else { + call sscan (Memc[projpars]) + call gargwrd (Memc[projstr], SZ_FNAME) + proj = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projpars] = EOS + if (sx2 == NULL && sy2 == NULL) + mw = cc_geowcs (coo, Memc[projpars], lngref, latref, + sx1, sy1, false) + else + mw = cc_celwcs (coo, Memc[projpars], lngref, latref) + } + } + + call sfree (sp) +end + + +# CC_FREE_TRANSFORM -- Free the previously defined transformation. + +procedure cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + +pointer sx1, sy1 #U pointers to the linear x and y surfaces +pointer sx2, sy2 #U pointers to the x and y distortion surfaces +pointer mw #U pointer to the mwcs structure +pointer coo #U pointer to the celestial coordinate structure + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) +end + + +# CC_LINIT -- Compute the required wcs structure from the input parameters. + +procedure cc_linit (lngunits, latunits, mw, coo) + +int lngunits #I the input ra / longitude units +int latunits #I the input dec / latitude units +pointer mw #O pointer to the mwcs structure +pointer coo #O pointer to the celestial coordinate structure + +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +int coostat, proj, tlngunits, tlatunits, pfd +pointer sp, projstr +double clgetd() +int sk_decwcs(), sk_stati(), open(), strdic(), cc_rdproj() +pointer cc_mkwcs() +errchk open() + +begin + # Allocate some workin space. + call smark (sp) + call salloc (projstr, SZ_LINE, TY_CHAR) + + # Get the reference point pixel coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = 0.0d0 + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = 0.0d0 + + xscale = clgetd ("xmag") + if (IS_INDEFD(xscale)) + xscale = 1.0d0 + yscale = clgetd ("ymag") + if (IS_INDEFD(yscale)) + yscale = 1.0d0 + + xrot = clgetd ("xrotation") + if (IS_INDEFD(xrot)) + xrot = 0.0d0 + yrot = clgetd ("yrotation") + if (IS_INDEFD(yrot)) + yrot = 0.0d0 + + lngref = clgetd ("lngref") + if (IS_INDEFD(lngref)) + lngref = 0.0d0 + latref = clgetd ("latref") + if (IS_INDEFD(latref)) + latref = 0.0d0 + + coostat = sk_decwcs ("j2000", mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + } + if (lngunits <= 0) + tlngunits = sk_stati (coo, S_NLNGUNITS) + else + tlngunits = lngunits + call sk_seti (coo, S_NLNGUNITS, tlngunits) + if (latunits <= 0) + tlatunits = sk_stati (coo, S_NLATUNITS) + else + tlatunits = latunits + call sk_seti (coo, S_NLATUNITS, tlatunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + + + mw = cc_mkwcs (coo, Memc[projstr], lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, false) + + call sfree (sp) +end + + +# CC_DTRECORD -- Read the transform from the database records written by +# CCMAP. + +int procedure cc_dtrecord (dt, record, geometry, coo, projection, + lngref, latref, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to the database +char record[ARB] #I the database records to be read +int geometry #I the transform geometry +pointer coo #O pointer to the coordinate structure +char projection[ARB] #O the sky projection geometry +double lngref, latref #O the reference point world coordinates +pointer sx1, sy1 #O pointer to the linear x and y fits +pointer sx2, sy2 #O pointer to the distortion x and y fits + +int i, op, ncoeff, junk, rec, coostat, lngunits, latunits +pointer mw, xcoeff, ycoeff, sp, projpar, projvalue +double dtgetd() +int dtlocate(), dtgeti(), dtscan(), sk_decwcs(), strdic(), strlen() +int gstrcpy() +errchk dgsrestore(), dtgstr(), dtdgetd(), dtgeti() + +begin + # Locate the appropriate records. + iferr (rec = dtlocate (dt, record)) + return (ERR) + + # Open the coordinate structure. + iferr (call dtgstr (dt, rec, "coosystem", projection, SZ_FNAME)) + return (ERR) + coostat = sk_decwcs (projection, mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + projection[1] = EOS + return (ERR) + } + + # Get the reference point units. + iferr (call dtgstr (dt, rec, "lngunits", projection, SZ_FNAME)) + return (ERR) + lngunits = strdic (projection, projection, SZ_FNAME, SKY_LNG_UNITLIST) + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + iferr (call dtgstr (dt, rec, "latunits", projection, SZ_FNAME)) + return (ERR) + latunits = strdic (projection, projection, SZ_FNAME, SKY_LAT_UNITLIST) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Get the reference point. + iferr (call dtgstr (dt, rec, "projection", projection, SZ_FNAME)) + return (ERR) + iferr (lngref = dtgetd (dt, rec, "lngref")) + return (ERR) + iferr (latref = dtgetd (dt, rec, "latref")) + return (ERR) + + # Read in the coefficients. + iferr (ncoeff = dtgeti (dt, rec, "surface1")) + return (ERR) + call malloc (xcoeff, ncoeff, TY_DOUBLE) + call malloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore the fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + call realloc (xcoeff, ncoeff, TY_DOUBLE) + call realloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore distortion part of fit. + iferr { + call dgsrestore (sx2, Memd[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Memd[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + sx2 = NULL + sy2 = NULL + } + + # Get the projection parameters if any. + call smark (sp) + call salloc (projpar, SZ_FNAME, TY_CHAR) + call salloc (projvalue, SZ_FNAME, TY_CHAR) + op = strlen (projection) + 1 + do i = 0, 9 { + call sprintf (Memc[projpar], SZ_FNAME, "projp%d") + call pargi (i) + iferr (call dtgstr (dt, rec, Memc[projpar], Memc[projvalue], + SZ_FNAME)) + next + op = op + gstrcpy (" ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projpar], projection[op], + SZ_LINE - op + 1) + op = op + gstrcpy (" = ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projvalue], projection[op], + SZ_LINE - op + 1) + } + call sfree (sp) + + + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + + return (OK) +end + + +define MAX_NITER 20 + +# CC_DO_TRANSFORM -- Transform the coordinates using the full transformation +# computed by CCMAP and the MWCS celestial coordinate wcs. + +procedure cc_do_transform (x, y, xt, yt, ct, sx1, sy1, sx2, sy2, forward) + +double x, y #I initial positions +double xt, yt #O transformed positions +pointer ct #I pointer to the mwcs transform +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +bool forward #I forward transform + +double xm, ym, f, fx, fy, g, gx, gy, denom, dx, dy +int niter +pointer sumsx, sumsy, newsx, newsy +double dgseval() + +begin + + if (forward) { + + xm = dgseval (sx1, x, y) + if (sx2 != NULL) + xm = xm + dgseval (sx2, x, y) + ym = dgseval (sy1, x, y) + if (sy2 != NULL) + ym = ym + dgseval (sy2, x, y) + xm = xm / 3600.0d0 + ym = ym / 3600.0d0 + + call mw_c2trand (ct, xm, ym, xt, yt) + + } else { + + # Use a value of 1.0 for an initial guess at the plate scale. + call mw_c2trand (ct, x, y, xm, ym) + xm = xm * 3600.0d0 + ym = ym * 3600.0d0 + + call dgsadd (sx1, sx2, sumsx) + call dgsadd (sy1, sy2, sumsy) + + niter = 0 + xt = xm + yt = ym + repeat { + + if (niter == 0) { + newsx = sx1 + newsy = sy1 + } else if (niter == 1) { + newsx = sumsx + newsy = sumsy + } + + f = dgseval (newsx, xt, yt) - xm + call dgsder (newsx, xt, yt, fx, 1, 1, 0) + call dgsder (newsx, xt, yt, fy, 1, 0, 1) + + g = dgseval (newsy, xt, yt) - ym + call dgsder (newsy, xt, yt, gx, 1, 1, 0) + call dgsder (newsy, xt, yt, gy, 1, 0, 1) + + denom = fx * gy - fy * gx + if (denom == 0.0d0) + break + dx = (-f * gy + g * fy) / denom + dy = (-g * fx + f * gx) / denom + xt = xt + dx + yt = yt + dy + if (max (abs (dx), abs (dy), abs(f), abs(g)) < 1.0e-5) + break + + niter = niter + 1 + + } until (niter >= MAX_NITER) + + call dgsfree (sumsx) + call dgsfree (sumsy) + } +end + +define NEWCD Memd[cd+(($2)-1)*ndim+($1)-1] + +# CC_MKWCS -- Compute the wcs from the user parameters. + +pointer procedure cc_mkwcs (coo, projection, lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, transpose) + +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +int ndim +double tlngref, tlatref +pointer sp, axes, ltm, ltv, r, w, cd, mw, projstr, projpars, wpars +int sk_stati() +pointer mw_open() + +begin + # Open the wcs. + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working space. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axes, ndim, TY_INT) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes. + Memi[axes] = 1 + Memi[axes+1] = 2 + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Compute the referemce point world coordinates. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + + if (! transpose) { + Memd[w] = tlngref + Memd[w+1] = tlatref + } else { + Memd[w+1] = tlngref + Memd[w] = tlatref + } + + # Compute the reference point pixel coordinates. + Memd[r] = xref + Memd[r+1] = yref + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(1,1) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,1) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(1,2) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,2) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + } else { + NEWCD(1,1) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,1) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(1,2) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(2,2) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + } + + # Compute the Lterm. + call aclrd (Memd[ltv], ndim) + call mw_mkidmd (Memd[ltm], ndim) + + # Store the wcs. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + +# CC_GEOWCS -- Create the wcs from the geometric transformation computed +# by CCMAP + +pointer procedure cc_geowcs (coo, projection, lngref, latref, sx1, sy1, + transpose) + +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the coordinates of the reference point +pointer sx1, sy1 #I pointer to linear surfaces +bool transpose #I transpose the wcs + +int ndim +double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref +pointer mw, sp, projstr, projpars, wpars, r, w, cd, ltm, ltv, axes +int sk_stati() +pointer mw_open() + +begin + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (axes, 2, TY_INT) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes. + Memi[axes] = 1 + Memi[axes+1] = 2 + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Compute the new referemce point. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + if (! transpose) { + Memd[w] = tlngref + Memd[w+1] = tlatref + } else { + Memd[w] = tlatref + Memd[w+1] = tlngref + } + + + # Fetch the linear coefficients of the fit. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the new reference pixel. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + Memd[r] = xpix + Memd[r+1] = ypix + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(1,1) = a / 3600.0d0 + NEWCD(1,2) = c / 3600.0d0 + NEWCD(2,1) = b / 3600.0d0 + NEWCD(2,2) = d / 3600.0d0 + } else { + NEWCD(1,1) = c / 3600.0d0 + NEWCD(1,2) = a / 3600.0d0 + NEWCD(2,1) = d / 3600.0d0 + NEWCD(2,2) = b / 3600.0d0 + } + + # Compute the Lterm. + call aclrd (Memd[ltv], ndim) + call mw_mkidmd (Memd[ltm], ndim) + + # Recompute and store the new wcs if update is enabled. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + + + + +# CC_CELWCS -- Create a wcs which compute the projection part of the +# transformation only + +pointer procedure cc_celwcs (coo, projection, lngref, latref) + +pointer coo #I the pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the position of the reference point. + +int ndim +pointer sp, projstr, projpars, wpars, ltm, ltv, cd, r, w, axes, mw +int sk_stati() +pointer mw_open() + +begin + # Open the wcs. + ndim = 2 + mw = mw_open (NULL, ndim) + + # Allocate working space. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (axes, 2, TY_INT) + + + # Set the wcs. + iferr (call mw_newsystem (mw, "image", ndim)) + ; + + # Set the axes and projection type. + Memi[axes] = 1 + Memi[axes+1] = 2 + if (projection[1] == EOS) { + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Set the lterm. + call mw_mkidmd (Memd[ltm], ndim) + call aclrd (Memd[ltv], ndim) + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + + # Set the wterm. + call mw_mkidmd (Memd[cd], ndim) + call aclrd (Memd[r], ndim) + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + Memd[w] = lngref + case SKY_RADIANS: + Memd[w] = RADTODEG(lngref) + case SKY_HOURS: + Memd[w] = 15.0d0 * lngref + default: + Memd[w] = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + Memd[w+1] = latref + case SKY_RADIANS: + Memd[w+1] = RADTODEG(latref) + case SKY_HOURS: + Memd[w+1] = 15.0d0 * latref + default: + Memd[w+1] = latref + } + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + call sfree (sp) + + return (mw) +end + + diff --git a/pkg/images/imcoords/src/healpix.x b/pkg/images/imcoords/src/healpix.x new file mode 100644 index 00000000..1156607c --- /dev/null +++ b/pkg/images/imcoords/src/healpix.x @@ -0,0 +1,492 @@ +include + +define MTYPES "|nest|ring|" +define NEST 1 +define RING 2 + +define NS_MAX 8192 +define TWOTHIRDS 0.66666666667 + + +# ANG2PIX -- Compute the HEALPix map row from a spherical coordinate. +# +# It is up to the caller to know the coordinate type, map type, and +# resolution for the map. +# +# The returned row is 1 indexed. + +procedure ang2row (row, lng, lat, mtype, nside) + +int row #O Table row +double lng #I Longitude (deg) +double lat #I Latitude (deg) +int mtype #I HEALPix map type +int nside #I Resolution parameter + +int ipix +double phi, theta +errchk ang2pix_nest, ang2pix_ring + +begin + # Check parameters and call appropriate procedure. + + if (nside < 1 || nside > NS_MAX) + call error (1, "nside out of range") + + if (lat < -90D0 || lat > 90D0) + call error (2, "latitude out of range") + + phi = DEGTORAD (lng) + theta = DEGTORAD (90D0 - lat) + + switch (mtype) { + case NEST: + call ang2pix_nest (nside, theta, phi, ipix) + case RING: + call ang2pix_ring (nside, theta, phi, ipix) + default: + call error (3, "unknown HEALPix map type") + } + + row = ipix + 1 +end + + +# PIX2ANG -- Compute spherical coordinate from HEALPix map row. +# +# It is up to the caller to know the coordinate type, map type, and +# resolution for the map. + +procedure row2ang (row, lng, lat, mtype, nside) + +int row #I Table row (1 indexed) +double lng #O Longitude (deg) +double lat #O Latitude (deg) +int mtype #I HEALPix map type +int nside #I Resolution parameter + +int ipix +double phi, theta +errchk pix2ang_nest, pix2ang_ring + +begin + # Check input parameters and call appropriate procedure. + + if (nside < 1 || nside > NS_MAX) + call error (1, "nside out of range") + + if (row < 1 || row > 12*nside*nside) + call error (1, "row out of range") + + ipix = row - 1 + + switch (mtype) { + case NEST: + call pix2ang_nest (nside, ipix, theta, phi) + case RING: + call pix2ang_ring (nside, ipix, theta, phi) + default: + call error (3, "unknown HEALPix map type") + } + + lng = RADTODEG (phi) + lat = 90D0 - RADTODEG (theta) +end + + +# The following routines are SPP translations of the HEALPix software from +# the authors identified below. If it matters, the C version was used +# though the translation is not necessarily exact. Comments were +# largely removed. +# +# I'm not sure if the arguments to the floor function in the original +# can be negative. Assuming not I just do an integer truncation. + +# ----------------------------------------------------------------------------- +# +# Copyright (C) 1997-2008 Krzysztof M. Gorski, Eric Hivon, +# Benjamin D. Wandelt, Anthony J. Banday, +# Matthias Bartelmann, +# Reza Ansari & Kenneth M. Ganga +# +# +# This file is part of HEALPix. +# +# HEALPix is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published +# by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# HEALPix is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with HEALPix; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +# 02110-1301 USA +# +# For more information about HEALPix see http://healpix.jpl.nasa.gov +# +#----------------------------------------------------------------------------- + + +# ANG2PIX_NEST -- Compute HEALPix index for a nested map. + +procedure ang2pix_nest (nside, theta, phi, ipix) + +int nside #I Resolution parameter +double theta #I Latitude (rad from pole) +double phi #I Longitude (rad) +int ipix #O HEALPix index + +double z, za, tt, tp, tmp +int face_num, jp, jm +long ifp, ifm +int ix, iy, ix_low, ix_hi, iy_low, iy_hi, ipf, ntt +int x2pix[128], y2pix[128] +int setup_done + +errchk mk_xy2pix + +data setup_done/NO/ + +begin + if (setup_done == NO) { + call mk_xy2pix (x2pix, y2pix) + setup_done = YES + } + + z = cos (theta) + za = abs (z) + if (phi >= TWOPI) + phi = phi - TWOPI + if (phi < 0.) + phi = phi + TWOPI + tt = phi / HALFPI + + if (za <= TWOTHIRDS) { + jp = int (NS_MAX * (0.5 + tt - z * 0.75)) + jm = int (NS_MAX * (0.5 + tt + z * 0.75)) + + ifp = jp / NS_MAX + ifm = jm / NS_MAX + + if (ifp==ifm) + face_num = mod (ifp, 4) + 4 + else if (ifp= 4) + ntt = 3 + tp = tt - ntt + tmp = sqrt (3. * (1. - za)) + + jp = int (NS_MAX * tp * tmp) + jm = int (NS_MAX * (1. - tp) * tmp) + jp = min (jp, NS_MAX-1) + jm = min (jm, NS_MAX-1) + + if (z >= 0) { + face_num = ntt + ix = NS_MAX - jm - 1 + iy = NS_MAX - jp - 1 + } else { + face_num = ntt + 8 + ix = jp + iy = jm + } + } + + ix_low = mod (ix, 128) + 1 + ix_hi = ix / 128 + 1 + iy_low = mod (iy, 128) + 1 + iy_hi = iy / 128 + 1 + + ipf = (x2pix[ix_hi] + y2pix[iy_hi]) * (128 * 128) + + (x2pix[ix_low] + y2pix[iy_low]) + ipf = ipf / (NS_MAX/nside)**2 + ipix = ipf + face_num * nside**2 +end + + +# ANG2PIX_RING -- Compute HEALPix index for a ring map. + +procedure ang2pix_ring (nside, theta, phi, ipix) + +int nside #I Resolution parameter +double theta #I Latitude (rad from pole) +double phi #I Longitude (rad) +int ipix #O HEALPix index + +int nl2, nl4, ncap, npix, jp, jm, ipix1 +double z, za, tt, tp, tmp +int ir, ip, kshift + +begin + z = cos (theta) + za = abs (z) + if ( phi >= TWOPI) + phi = phi - TWOPI + if (phi < 0.) + phi = phi + TWOPI + tt = phi / HALFPI + + nl2 = 2 * nside + nl4 = 4 * nside + ncap = nl2 * (nside - 1) + npix = 12 * nside * nside + + if (za <= TWOTHIRDS) { + + jp = int (nside * (0.5 + tt - z * 0.75)) + jm = int (nside * (0.5 + tt + z * 0.75)) + + ir = nside + 1 + jp - jm + kshift = 0 + if (mod (ir,2) == 0) + kshift = 1 + + ip = int ((jp + jm - nside + kshift + 1) / 2) + 1 + if (ip > nl4) + ip = ip - nl4 + + ipix1 = ncap + nl4 * (ir - 1) + ip + } else { + + tp = tt - int (tt) + tmp = sqrt (3. * (1. - za)) + + jp = int (nside * tp * tmp) + jm = int (nside * (1. - tp) * tmp) + + ir = jp + jm + 1 + ip = int (tt * ir) + 1 + if (ip > 4*ir) + ip = ip - 4 * ir + + ipix1 = 2 * ir * (ir - 1) + ip + if (z<=0.) { + ipix1 = npix - 2 * ir * (ir + 1) + ip + } + } + ipix = ipix1 - 1 +end + + +# PIX2ANG_NEST -- Translate HEALpix nested row to spherical coordinates. + +procedure pix2ang_nest (nside, ipix, theta, phi) + +int nside #I Resolution parameter +int ipix #I HEALPix index +double theta #O Latitude (rad from pole) +double phi #O Longitude (rad) + +int npface, face_num +int ipf, ip_low, ip_trunc, ip_med, ip_hi +int ix, iy, jrt, jr, nr, jpt, jp, kshift, nl4 +double z, fn, fact1, fact2 + +int pix2x[1024], pix2y[1024] + +int jrll[12], jpll[12], setup_done +data jrll/2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4/ +data jpll/1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7/ +data setup_done/NO/ + +begin + if (setup_done == NO) { + call mk_pix2xy (pix2x,pix2y) + setup_done = YES + } + + fn = 1. * nside + fact1 = 1. / (3. * fn * fn) + fact2 = 2. / (3. * fn) + nl4 = 4 * nside + + npface = nside * nside + + face_num = ipix / npface + 1 + ipf = mod (ipix, npface) + + ip_low = mod (ipf, 1024) + 1 + ip_trunc = ipf / 1024 + ip_med = mod (ip_trunc, 1024) + 1 + ip_hi = ip_trunc / 1024 + 1 + + ix = 1024*pix2x[ip_hi] + 32*pix2x[ip_med] + pix2x[ip_low] + iy = 1024*pix2y[ip_hi] + 32*pix2y[ip_med] + pix2y[ip_low] + + jrt = ix + iy + jpt = ix - iy + + jr = jrll[face_num] * nside - jrt - 1 + nr = nside + z = (2 * nside - jr) * fact2 + kshift = mod (jr - nside, 2) + if( jr < nside) { + nr = jr + z = 1. - nr * nr * fact1 + kshift = 0 + } else if (jr > 3*nside) { + nr = nl4 - jr + z = - 1. + nr * nr * fact1 + kshift = 0 + } + + jp = (jpll[face_num] * nr + jpt + 1 + kshift)/2 + if (jp > nl4) + jp = jp - nl4 + if (jp < 1) + jp = jp + nl4 + + theta = acos(z) + phi = (jp - (kshift+1)*0.5) * (HALFPI / nr) +end + + +# PIX2ANG_RING -- Convert HEALpix pixel to spherical coordinates. + +procedure pix2ang_ring (nside, ipix, theta, phi) + +int nside #I Resolution parameter +int ipix #I HEALPix index +double theta #O Latitude (rad from pole) +double phi #O Longitude (rad) + +int nl2, nl4, npix, ncap, iring, iphi, ip, ipix1 +double fact1, fact2, fodd, hip, fihip + +begin + npix = 12 * nside * nside + ipix1 = ipix + 1 + nl2 = 2 * nside + nl4 = 4 * nside + ncap = 2 * nside * (nside - 1) + fact1 = 1.5 * nside + fact2 = 3.0 * nside * nside + + if (ipix1 <= ncap) { + + hip = ipix1 / 2. + fihip = int (hip) + iring = int (sqrt (hip - sqrt (fihip))) + 1 + iphi = ipix1 - 2 * iring * (iring - 1) + + theta = acos (1. - iring * iring / fact2) + phi = (iphi - 0.5) * PI / (2. * iring) + + } else if (ipix1 <= nl2 * (5 * nside + 1)) { + + ip = ipix1 - ncap - 1 + iring = (ip / nl4) + nside + iphi = mod (ip, nl4) + 1 + + fodd = 0.5 * (1 + mod (iring + nside, 2)) + theta = acos ((nl2 - iring) / fact1) + phi = (iphi - fodd) * PI / (2. * nside) + + } else { + + ip = npix - ipix1 + 1 + hip = ip/2. + + fihip = int (hip) + iring = int (sqrt (hip - sqrt (fihip))) + 1 + iphi = 4. * iring + 1 - (ip - 2. * iring * (iring-1)) + + theta = acos (-1. + iring * iring / fact2) + phi = (iphi - 0.5) * PI / (2. * iring) + + } +end + + +# MK_XY2PIX +# +# Sets the array giving the number of the pixel lying in (x,y) +# x and y are in {1,128} +# the pixel number is in {0,128**2-1} +# +# if i-1 = sum_p=0 b_p * 2^p +# then ix = sum_p=0 b_p * 4^p +# iy = 2*ix +# ix + iy in {0, 128**2 -1} + +procedure mk_xy2pix (x2pix, y2pix) + +int x2pix[128], y2pix[128] + +int i, j, k, ip, id + +begin + do i = 1, 128 + x2pix[i] = 0 + + do i = 1, 128 { + j = i - 1 + k = 0 + ip = 1 + while (j != 0) { + id = mod (j, 2) + j = j / 2 + k = ip * id + k + ip = ip * 4 + } + x2pix[i] = k + y2pix[i] = 2 * k + } +end + + +# MK_PIX2XY +# +# Constructs the array giving x and y in the face from pixel number +# for the nested (quad-cube like) ordering of pixels. +# +# The bits corresponding to x and y are interleaved in the pixel number. +# One breaks up the pixel number by even and odd bits. + +procedure mk_pix2xy (pix2x, pix2y) + +int pix2x[1024], pix2y[1024] + +int kpix, jpix, ix, iy, ip, id + +begin + + do kpix = 1, 1024 + pix2x[kpix] = 0 + + do kpix = 1, 1024 { + jpix = kpix - 1 + ix = 0 + iy = 0 + ip = 1 + while (jpix != 0) { + id = mod (jpix, 2) + jpix = jpix / 2 + ix = id * ip + ix + + id = mod (jpix, 2) + jpix = jpix / 2 + iy = id * ip + iy + + ip = 2 * ip + } + + pix2x[kpix] = ix + pix2y[kpix] = iy + } + +end diff --git a/pkg/images/imcoords/src/mkcwcs.cl b/pkg/images/imcoords/src/mkcwcs.cl new file mode 100644 index 00000000..fde777cd --- /dev/null +++ b/pkg/images/imcoords/src/mkcwcs.cl @@ -0,0 +1,94 @@ +# MKCWCS -- Make celestial WCS. + +procedure mkcwcs (wcsname) + +file wcsname {prompt="WCS to create"} +file wcsref = "" {prompt="WCS reference\n"} + +real equinox = INDEF {prompt="Equinox (years)"} +real ra = INDEF {prompt="RA (hours)"} +real dec = INDEF {prompt="DEC (degrees)"} +real scale = INDEF {prompt="Celestial pixel scale (arcsec/pix)"} +real pa = 0. {prompt="Position angle (deg)"} +bool lefthanded = yes {prompt="Left-handed system?"} +string projection = "tan" {prompt="Celestial projection\n", + enum="linear|tan|sin"} + +real rapix = INDEF {prompt="RA reference pixel"} +real decpix = INDEF {prompt="DEC reference pixel"} + +begin + int wcsdim = 2 + real c, s, lh + file name, ref, wcs + + # Determine the input and reference images. + name = wcsname + if (fscan (wcsref, ref) > 0) + wcscopy (name, ref) + + # Set the axes. + if (imaccess (name)) { + hedit (name, "ctype1", "RA---TAN", + add+, addonly-, verify-, show-, update+) + hedit (name, "ctype2", "DEC---TAN", + add+, addonly-, verify-, show-, update+) + } + wcsedit (name, "axtype", "ra", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "axtype", "dec", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "wtype", projection, "1,2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the celestial equinox if desired. Note this is not WCS. + if (equinox != INDEF) + hedit (name, "equinox", equinox, + add+, addonly-, verify-, show-, update+) + + # Set the reference point if desired. + if (ra != INDEF) + wcsedit (name, "crval", ra*15, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (dec != INDEF) + wcsedit (name, "crval", dec, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the scales and celestial position angle. + if (scale != INDEF) { + if (pa != INDEF) { + c = cos (pa * 3.14159 / 180.) / 3600. + s = sin (pa * 3.14159 / 180.) / 3600. + } else { + c = 1. + s = 0. + } + if (lefthanded) { + wcsedit (name, "cd", -scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } else { + wcsedit (name, "cd", scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } + } + + # Set reference pixel if desired. + if (rapix != INDEF) + wcsedit (name, "crpix", rapix, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (decpix != INDEF) + wcsedit (name, "crpix", decpix, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) +end diff --git a/pkg/images/imcoords/src/mkcwwcs.cl b/pkg/images/imcoords/src/mkcwwcs.cl new file mode 100644 index 00000000..30e26814 --- /dev/null +++ b/pkg/images/imcoords/src/mkcwwcs.cl @@ -0,0 +1,102 @@ +# MKCWWCS -- MaKe Celestial, Wavelength 3D World Coordinate System + +procedure mkcwwcs (wcsname) + +file wcsname {prompt="WCS to create"} +file wcsref = "" {prompt="WCS reference\n"} + +real equinox = INDEF {prompt="Equinox (years)"} +real ra = INDEF {prompt="RA (hours)"} +real dec = INDEF {prompt="DEC (degrees)"} +real scale = INDEF {prompt="Celestial pixel scale (arcsec/pix)"} +real pa = 0. {prompt="Position angle (deg)"} +bool lefthanded = yes {prompt="Left-handed system?"} +string projection = "tan" {prompt="Celestial projection\n", + enum="linear|tan|sin"} + +real wave = INDEF {prompt="Wavelength"} +real wscale = INDEF {prompt="Wavelength scale\n"} + +real rapix = INDEF {prompt="RA reference pixel"} +real decpix = INDEF {prompt="DEC reference pixel"} +real wpix = INDEF {prompt="Wavelength reference pixel"} + +begin + int wcsdim = 3 + real c, s, lh + file name, ref, wcs + + # Determine the input and reference images. + name = wcsname + if (fscan (wcsref, ref) > 0) + wcscopy (name, ref) + + # Set the axes. + wcsedit (name, "axtype", "ra", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "axtype", "dec", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "wtype", projection, "1,2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the celestial equinox if desired. Note this is not WCS. + if (equinox != INDEF) + hedit (name, "equinox", equinox, + add+, addonly-, verify-, show-, update+) + + # Set the reference point if desired. + if (ra != INDEF) + wcsedit (name, "crval", ra*15, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (dec != INDEF) + wcsedit (name, "crval", dec, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (wave != INDEF) + wcsedit (name, "crval", wave, "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set the scales and celestial position angle. + if (scale != INDEF) { + if (pa != INDEF) { + c = cos (pa * 3.14159 / 180.) / 3600. + s = sin (pa * 3.14159 / 180.) / 3600. + } else { + c = 1. + s = 0. + } + if (lefthanded) { + wcsedit (name, "cd", -scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } else { + wcsedit (name, "cd", scale*c, "1", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", -scale*s, "1", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*s, "2", "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + wcsedit (name, "cd", scale*c, "2", "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + } + } + if (wscale != INDEF) + wcsedit (name, "cd", wscale, "3", "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + + # Set reference pixel if desired. + if (rapix != INDEF) + wcsedit (name, "crpix", rapix, "1", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (decpix != INDEF) + wcsedit (name, "crpix", decpix, "2", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + if (wpix != INDEF) + wcsedit (name, "crpix", wpix, "3", wcsdim=wcsdim, + wcs="world", interactive-, verbose-, update+) + +end diff --git a/pkg/images/imcoords/src/mkpkg b/pkg/images/imcoords/src/mkpkg new file mode 100644 index 00000000..6b1632ab --- /dev/null +++ b/pkg/images/imcoords/src/mkpkg @@ -0,0 +1,47 @@ +# Library for the IMAGES IMCOORDS Subpackage Tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (rgstr.x, rgstr.gx) + $(GEN) rgstr.gx -o rgstr.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + ccfunc.x \ + + ccstd.x + ccxytran.x + healpix.x + rgstr.x + sfconvolve.x starfind.h + sffind.x \ + starfind.h + sftools.x starfind.h + skyctran.x + t_ccfind.x + t_ccget.x \ + + t_ccmap.x \ + "../../lib/geomap.h" + t_ccsetwcs.x + t_ccstd.x + t_cctran.x + t_ccxymatch.x "../../lib/xyxymatch.h" + t_hpctran.x + t_imcctran.x \ + + t_skyctran.x + t_starfind.x + t_wcsctran.x \ + + t_wcsedit.x + t_wcsreset.x + ; diff --git a/pkg/images/imcoords/src/rgstr.gx b/pkg/images/imcoords/src/rgstr.gx new file mode 100644 index 00000000..3647f80b --- /dev/null +++ b/pkg/images/imcoords/src/rgstr.gx @@ -0,0 +1,109 @@ +include + +$for (rd) + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +PIXEL coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_field$t (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_field$t (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +$endfor diff --git a/pkg/images/imcoords/src/rgstr.x b/pkg/images/imcoords/src/rgstr.x new file mode 100644 index 00000000..4e3d0836 --- /dev/null +++ b/pkg/images/imcoords/src/rgstr.x @@ -0,0 +1,215 @@ +include + + + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_liner (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +real coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_fieldr (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_fieldr (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + + + +# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed +# fields are converted to strings; other fields are copied from the input +# line to the output buffer. + +procedure rg_apack_lined (inbuf, outbuf, maxch, field_pos, nfields, + cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int cinfields[ARB] #I fields to be replaced +int ncin #I the number of input fields +double coords[ARB] #I the transformed coordinates +int laxno[ARB] #I the logical axis mapping +pointer formats[ARB] #I array of format pointers +int nsdig[ARB] #I array of numbers of significant digits +int ncout #I the number of coordinates +int min_sigdigits #I the minimum number of signficant digits + +int op, num_field, width, cf, cfptr +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + # Copy the file replacing fields as one goes. + do num_field = 1, nfields { + + # Find the width of the field. + width = field_pos[num_field + 1] - field_pos[num_field] + + # Find the field to be replaced. + cfptr = 0 + do cf = 1, ncin { + if (cinfields[cf] != num_field) + next + cfptr = cf + break + } + + # Replace the field. + if (cfptr != 0) { + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, + #Memc[formats[cfptr]], nsdig[cfptr], width, + #min_sigdigits) + } else + call li_format_fieldd (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + do cfptr = ncin + 1, ncout { + + # Copy out the extra fields if any. + if (laxno[cfptr] == 0) { + Memc[field] = EOS + next + #call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g", + #min_sigdigits, width, min_sigdigits) + } else + call li_format_fieldd (coords[laxno[cfptr]], Memc[field], + maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]], + width, min_sigdigits) + + # Fields must be delimited by at least one blank. + if (!IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + + diff --git a/pkg/images/imcoords/src/sfconvolve.x b/pkg/images/imcoords/src/sfconvolve.x new file mode 100644 index 00000000..39411c2d --- /dev/null +++ b/pkg/images/imcoords/src/sfconvolve.x @@ -0,0 +1,398 @@ +include +include +include "starfind.h" + + +# SF_EGPARAMS -- Calculate the parameters of the elliptical Gaussian needed +# to compute the Gaussian convolution kernel. + +procedure sf_egparams (sigma, ratio, theta, nsigma, a, b, c, f, nx, ny) + +real sigma #I sigma of Gaussian in x +real ratio #I ratio of half-width in y to x +real theta #I position angle of Gaussian +real nsigma #I limit of convolution +real a, b, c, f #O ellipse parameters +int nx, ny #O dimensions of the kernel + +real sx2, sy2, cost, sint, discrim +bool fp_equalr () + +begin + # Define some temporary variables. + sx2 = sigma ** 2 + sy2 = (ratio * sigma) ** 2 + cost = cos (DEGTORAD (theta)) + sint = sin (DEGTORAD (theta)) + + # Compute the ellipse parameters. + if (fp_equalr (ratio, 0.0)) { + if (fp_equalr (theta, 0.0) || fp_equalr (theta, 180.)) { + a = 1. / sx2 + b = 0.0 + c = 0.0 + } else if (fp_equalr (theta, 90.0)) { + a = 0.0 + b = 0.0 + c = 1. / sx2 + } else + call error (0, "SF_EGPARAMS: Cannot make 1D Gaussian.") + f = nsigma ** 2 / 2. + nx = 2 * int (max (sigma * nsigma * abs (cost), RMIN)) + 1 + ny = 2 * int (max (sigma * nsigma * abs (sint), RMIN)) + 1 + } else { + a = cost ** 2 / sx2 + sint ** 2 / sy2 + b = 2. * (1.0 / sx2 - 1.0 / sy2) * cost * sint + c = sint ** 2 / sx2 + cost ** 2 / sy2 + discrim = b ** 2 - 4. * a * c + f = nsigma ** 2 / 2. + nx = 2 * int (max (sqrt (-8. * c * f / discrim), RMIN)) + 1 + ny = 2 * int (max (sqrt (-8. * a * f / discrim), RMIN)) + 1 + } +end + + +# SF_EGKERNEL -- Compute the non-normalized and normalized elliptical +# Gaussian kernel and the skip array. + +real procedure sf_egkernel (gkernel, ngkernel, skip, nx, ny, gsums, a, b, c, f) + +real gkernel[nx,ny] #O output Gaussian amplitude kernel +real ngkernel[nx,ny] #O output normalized Gaussian amplitude kernel +int skip[nx,ny] #O output skip subraster +int nx, ny #I input dimensions of the kernel +real gsums[ARB] #O output array of gsums +real a, b, c, f #I ellipse parameters + +int i, j, x0, y0, x, y +real rjsq, rsq, relerr, ef + +begin + # Initialize. + x0 = nx / 2 + 1 + y0 = ny / 2 + 1 + gsums[GAUSS_PIXELS] = 0.0 + gsums[GAUSS_SUMG] = 0.0 + gsums[GAUSS_SUMGSQ] = 0.0 + + # Compute the kernel and principal sums. + do j = 1, ny { + y = j - y0 + rjsq = y ** 2 + do i = 1, nx { + x = i - x0 + rsq = sqrt (x ** 2 + rjsq) + ef = 0.5 * (a * x ** 2 + c * y ** 2 + b * x * y) + gkernel[i,j] = exp (-1.0 * ef) + if (ef <= f || rsq <= RMIN) { + ngkernel[i,j] = gkernel[i,j] + gsums[GAUSS_SUMG] = gsums[GAUSS_SUMG] + gkernel[i,j] + gsums[GAUSS_SUMGSQ] = gsums[GAUSS_SUMGSQ] + + gkernel[i,j] ** 2 + skip[i,j] = NO + gsums[GAUSS_PIXELS] = gsums[GAUSS_PIXELS] + 1.0 + } else { + ngkernel[i,j] = 0.0 + skip[i,j] = YES + } + } + } + + # Store the remaining sums. + gsums[GAUSS_DENOM] = gsums[GAUSS_SUMGSQ] - gsums[GAUSS_SUMG] ** 2 / + gsums[GAUSS_PIXELS] + gsums[GAUSS_SGOP] = gsums[GAUSS_SUMG] / gsums[GAUSS_PIXELS] + + # Normalize the kernel. + do j = 1, ny { + do i = 1, nx { + if (skip[i,j] == NO) + ngkernel[i,j] = (gkernel[i,j] - gsums[GAUSS_SGOP]) / + gsums[GAUSS_DENOM] + } + } + + + relerr = 1.0 / gsums[GAUSS_DENOM] + + return (sqrt (relerr)) +end + + +# SF_FCONVOLVE -- Solve for the density enhancements in the case where +# datamin and datamax are not defined. + +procedure sf_fconvolve (im, c1, c2, l1, l2, bwidth, imbuf, denbuf, ncols, + nlines, kernel, skip, nxk, nyk) + +pointer im #I pointer to the input image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image +int bwidth #I width of pixel buffer +real imbuf[ncols,nlines] #O the output data buffer +real denbuf[ncols,nlines] #O the output density enhancement buffer +int ncols, nlines #I dimensions of the output buffers +real kernel[nxk,nyk] #I the convolution kernel +int skip[nxk,nyk] #I the skip array +int nxk, nyk #I dimensions of the kernel + +int i, col1, col2, inline, index, outline +pointer sp, lineptrs +pointer imgs2r() +errchk imgs2r + +begin + # Set up an array of linepointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Set the number of image buffers. + call imseti (im, IM_NBUFS, nyk) + + # Set input image column limits. + col1 = c1 - nxk / 2 - bwidth + col2 = c2 + nxk / 2 + bwidth + + # Initialise the line buffers at the same time copying the image + # input the data buffer. + inline = l1 - bwidth - nyk / 2 + do index = 1 , nyk - 1 { + Memi[lineptrs+index] = imgs2r (im, col1, col2, inline, inline) + call amovr (Memr[Memi[lineptrs+index]], imbuf[1,index], ncols) + inline = inline + 1 + } + + # Zero the initial density enhancement buffers. + do i = 1, nyk / 2 + call amovkr (0.0, denbuf[1,i], ncols) + + # Generate the output image line by line. + do outline = 1, l2 - l1 + 2 * bwidth + 1 { + + # Scroll the input buffers. + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line and copy it into the image buffer. + Memi[lineptrs+nyk-1] = imgs2r (im, col1, col2, inline, + inline) + + # Compute the input image line into the data buffer. + call amovr (Memr[Memi[lineptrs+nyk-1]], imbuf[1,index], ncols) + + # Generate first output image line. + call aclrr (denbuf[1,outline+nyk/2], ncols) + do i = 1, nyk + call sf_skcnvr (Memr[Memi[lineptrs+i-1]], + denbuf[1+nxk/2,outline+nyk/2], c2 - c1 + 2 * bwidth + 1, + kernel[1,i], skip[1,i], nxk) + + inline = inline + 1 + index = index + 1 + } + + # Zero the final density enhancement buffer lines. + do i = nlines - nyk / 2 + 1, nlines + call amovkr (0.0, denbuf[1,i], ncols) + + # Free the image buffer pointers. + call sfree (sp) +end + + +# SF_GCONVOLVE -- Solve for the density enhancement image in the case where +# datamin and datamax are defined. + +procedure sf_gconvolve (im, c1, c2, l1, l2, bwidth, imbuf, denbuf, ncols, + nlines, kernel, skip, nxk, nyk, gsums, datamin, datamax) + +pointer im # pointer to the input image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image +int bwidth #I width of pixel buffer +real imbuf[ncols,nlines] #O the output data buffer +real denbuf[ncols,nlines] #O the output density enhancement buffer +int ncols, nlines #I dimensions of the output buffers +real kernel[nxk,nyk] #I the first convolution kernel +int skip[nxk,nyk] #I the sky array +int nxk, nyk #I dimensions of the kernel +real gsums[ARB] #U array of kernel sums +real datamin, datamax #I the good data minimum and maximum + +int i, nc, col1, col2, inline, index, outline +pointer sp, lineptrs, sd, sgsq, sg, p +pointer imgs2r() +errchk imgs2r() + +begin + # Set up an array of linepointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Set the number of image buffers. + call imseti (im, IM_NBUFS, nyk) + + # Allocate some working space. + nc = c2 - c1 + 2 * bwidth + 1 + call salloc (sd, nc, TY_REAL) + call salloc (sgsq, nc, TY_REAL) + call salloc (sg, nc, TY_REAL) + call salloc (p, nc, TY_REAL) + + # Set input image column limits. + col1 = c1 - nxk / 2 - bwidth + col2 = c2 + nxk / 2 + bwidth + + # Initialise the line buffers. + inline = l1 - bwidth - nyk / 2 + do index = 1 , nyk - 1 { + Memi[lineptrs+index] = imgs2r (im, col1, col2, inline, inline) + call amovr (Memr[Memi[lineptrs+index]], imbuf[1,index], ncols) + inline = inline + 1 + } + + # Zero the initial density enhancement buffers. + do i = 1, nyk / 2 + call amovkr (0.0, denbuf[1,i], ncols) + + # Generate the output image line by line. + do outline = 1, l2 - l1 + 2 * bwidth + 1 { + + # Scroll the input buffers. + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line. + Memi[lineptrs+nyk-1] = imgs2r (im, col1, col2, inline, + inline) + + # Compute the input image line into the data buffer. + call amovr (Memr[Memi[lineptrs+nyk-1]], imbuf[1,index], ncols) + + # Generate first output image line. + call aclrr (denbuf[1,outline+nyk/2], ncols) + call aclrr (Memr[sd], nc) + call amovkr (gsums[GAUSS_SUMG], Memr[sg], nc) + call amovkr (gsums[GAUSS_SUMGSQ], Memr[sgsq], nc) + call amovkr (gsums[GAUSS_PIXELS], Memr[p], nc) + + do i = 1, nyk + call sf_gdsum (Memr[Memi[lineptrs+i-1]], + denbuf[1+nxk/2,outline+nyk/2], Memr[sd], + Memr[sg], Memr[sgsq], Memr[p], nc, kernel[1,i], + skip[1,i], nxk, datamin, datamax) + call sf_gdavg (denbuf[1+nxk/2,outline+nyk/2], Memr[sd], Memr[sg], + Memr[sgsq], Memr[p], nc, gsums[GAUSS_PIXELS], + gsums[GAUSS_DENOM], gsums[GAUSS_SGOP]) + + inline = inline + 1 + index = index + 1 + } + + # Zero the final density enhancement buffer lines. + do i = nlines - nyk / 2 + 1, nlines + call amovkr (0.0, denbuf[1,i], ncols) + + # Free the image buffer pointers. + call sfree (sp) +end + + +# SF_SKCNVR -- Compute the convolution kernel using a skip array. + +procedure sf_skcnvr (in, out, npix, kernel, skip, nk) + +real in[npix+nk-1] #I the input vector +real out[npix] #O the output vector +int npix #I the size of the vector +real kernel[ARB] #I the convolution kernel +int skip[ARB] #I the skip array +int nk #I the size of the convolution kernel + +int i, j +real sum + +begin + do i = 1, npix { + sum = out[i] + do j = 1, nk { + if (skip[j] == YES) + next + sum = sum + in[i+j-1] * kernel[j] + } + out[i] = sum + } +end + + +# SF_GDSUM -- Compute the vector sums required to do the convolution. + +procedure sf_gdsum (in, sgd, sd, sg, sgsq, p, npix, kernel, skip, nk, + datamin, datamax) + +real in[npix+nk-1] #I the input vector +real sgd[ARB] #U the computed input/output convolution vector +real sd[ARB] #U the computed input/output sum vector +real sg[ARB] #U the input/ouput first normalization factor +real sgsq[ARB] #U the input/ouput second normalization factor +real p[ARB] #U the number of points vector +int npix #I the size of the vector +real kernel[ARB] #I the convolution kernel +int skip[ARB] #I the skip array +int nk #I the size of the convolution kernel +real datamin, datamax #I the good data limits. + +int i, j +real data + +begin + do i = 1, npix { + do j = 1, nk { + if (skip[j] == YES) + next + data = in[i+j-1] + if (data < datamin || data > datamax) { + sgsq[i] = sgsq[i] - kernel[j] ** 2 + sg[i] = sg[i] - kernel[j] + p[i] = p[i] - 1.0 + } else { + sgd[i] = sgd[i] + kernel[j] * data + sd[i] = sd[i] + data + } + } + } +end + + +# SF_GDAVG -- Compute the vector averages required to do the convolution. + +procedure sf_gdavg (sgd, sd, sg, sgsq, p, npix, pixels, denom, sgop) + +real sgd[ARB] #U the computed input/output convolution vector +real sd[ARB] #I the computed input/output sum vector +real sg[ARB] #I the input/ouput first normalization factor +real sgsq[ARB] #U the input/ouput second normalization factor +real p[ARB] #I the number of points vector +int npix #I the size of the vector +real pixels #I number of pixels +real denom #I kernel normalization factor +real sgop #I kernel normalization factor + +int i + +begin + do i = 1, npix { + if (p[i] > 1.5) { + if (p[i] < pixels) { + sgsq[i] = sgsq[i] - (sg[i] ** 2) / p[i] + if (sgsq[i] != 0.0) + sgd[i] = (sgd[i] - sg[i] * sd[i] / p[i]) / sgsq[i] + else + sgd[i] = 0.0 + } else + sgd[i] = (sgd[i] - sgop * sd[i]) / denom + } else + sgd[i] = 0.0 + } +end + diff --git a/pkg/images/imcoords/src/sffind.x b/pkg/images/imcoords/src/sffind.x new file mode 100644 index 00000000..367893e5 --- /dev/null +++ b/pkg/images/imcoords/src/sffind.x @@ -0,0 +1,739 @@ +include +include +include +include +include +include +include "starfind.h" + + +# SF_FIND -- Find stars in an image using a pattern matching technique and +# a circularly symmetric Gaussian pattern. + +procedure sf_find (im, out, sf, nxblock, nyblock, wcs, wxformat, wyformat, + boundary, constant, verbose) + +pointer im #I pointer to the input image +int out #I the output file descriptor +pointer sf #I pointer to the apphot structure +int nxblock #I the x dimension blocking factor +int nyblock #I the y dimension blocking factor +char wcs[ARB] #I the world coordinate system +char wxformat[ARB] #I the x axis world coordinate format +char wyformat[ARB] #I the y axis world coordinate format +int boundary #I type of boundary extension +real constant #I constant for constant boundary extension +int verbose #I verbose switch + +int i, j, fwidth, swidth, norm +int l1, l2, c1, c2, ncols, nlines, nxb, nyb, nstars, stid +pointer sp, gker2d, ngker2d, skip, fmtstr, twxformat, twyformat +pointer imbuf, denbuf, str, mw, ct +real sigma, nsigma, a, b, c, f, gsums[LEN_GAUSS], relerr, dmin, dmax +real maglo, maghi + +bool streq() +int sf_stfind() +pointer mw_openim(), mw_sctran() +real sf_egkernel() +errchk mw_openim(), mw_sctran(), mw_gattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (twxformat, SZ_FNAME, TY_CHAR) + call salloc (twyformat, SZ_FNAME, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the parameters of the Gaussian kernel. + sigma = HWHM_TO_SIGMA * SF_HWHMPSF(sf) + nsigma = SF_FRADIUS(sf) / HWHM_TO_SIGMA + call sf_egparams (sigma, 1.0, 0.0, nsigma, a, b, c, f, fwidth, fwidth) + + # Compute the separation parameter + swidth = max (2, int (SF_SEPMIN(sf) * SF_HWHMPSF(sf) + 0.5)) + + # Compute the minimum and maximum pixel values. + if (IS_INDEFR(SF_DATAMIN(sf)) && IS_INDEFR(SF_DATAMAX(sf))) { + norm = YES + dmin = -MAX_REAL + dmax = MAX_REAL + } else { + norm = NO + if (IS_INDEFR(SF_DATAMIN(sf))) + dmin = -MAX_REAL + else + dmin = SF_DATAMIN(sf) + if (IS_INDEFR(SF_DATAMAX(sf))) + dmax = MAX_REAL + else + dmax = SF_DATAMAX(sf) + } + + # Compute the magnitude limits + if (IS_INDEFR(SF_MAGLO(sf))) + maglo = -MAX_REAL + else + maglo = SF_MAGLO(sf) + if (IS_INDEFR(SF_MAGHI(sf))) + maghi = MAX_REAL + else + maghi = SF_MAGHI(sf) + + # Open the image WCS. + if (wcs[1] == EOS) { + mw = NULL + ct = NULL + } else { + iferr { + mw = mw_openim (im) + } then { + call erract (EA_WARN) + mw = NULL + ct = NULL + } else { + iferr { + ct = mw_sctran (mw, "logical", wcs, 03B) + } then { + call erract (EA_WARN) + ct = NULL + call mw_close (mw) + mw = NULL + } + } + } + + # Set the WCS formats. + if (ct == NULL) + call strcpy (wxformat, Memc[twxformat], SZ_FNAME) + else if (wxformat[1] == EOS) { + if (mw != NULL) { + iferr (call mw_gwattrs (mw, 1, "format", Memc[twxformat], + SZ_FNAME)) { + if (streq (wcs, "world")) + call strcpy ("%11.8g", Memc[twxformat], SZ_FNAME) + else + call strcpy ("%9.3f", Memc[twxformat], SZ_FNAME) + } + } else + call strcpy ("%9.3f", Memc[twxformat], SZ_FNAME) + } else + call strcpy (wxformat, Memc[twxformat], SZ_FNAME) + if (ct == NULL) + call strcpy (wyformat, Memc[twyformat], SZ_FNAME) + else if (wyformat[1] == EOS) { + if (mw != NULL) { + iferr (call mw_gwattrs (mw, 2, "format", Memc[twyformat], + SZ_FNAME)) { + if (streq (wcs, "world")) + call strcpy ("%11.8g", Memc[twyformat], SZ_FNAME) + else + call strcpy ("%9.3f", Memc[twyformat], SZ_FNAME) + } + } else + call strcpy ("%9.3f", Memc[twyformat], SZ_FNAME) + } else + call strcpy (wyformat, Memc[twyformat], SZ_FNAME) + + # Create the output format string. + call sprintf (Memc[fmtstr], + SZ_LINE, " %s %s %s %s %s %s %s %s %s %s %s\n") + call pargstr ("%9.3f") + call pargstr ("%9.3f") + call pargstr (Memc[twxformat]) + call pargstr (Memc[twyformat]) + call pargstr ("%7.2f") + call pargstr ("%6d") + call pargstr ("%6.2f") + call pargstr ("%6.3f") + call pargstr ("%6.1f") + call pargstr ("%7.3f") + call pargstr ("%6d") + + # Set up the image boundary extension characteristics. + call imseti (im, IM_TYBNDRY, boundary) + call imseti (im, IM_NBNDRYPIX, 1 + fwidth / 2 + swidth) + if (boundary == BT_CONSTANT) + call imsetr (im, IM_BNDRYPIXVAL, constant) + + # Set up the blocking factor. + # Compute the magnitude limits + if (IS_INDEFI(nxblock)) + nxb = IM_LEN(im,1) + else + nxb = nxblock + if (IS_INDEFI(nyblock)) + nyb = IM_LEN(im,2) + else + nyb = nyblock + + # Print the detection criteria on the standard output. + if (verbose == YES) { + call fstats (out, F_FILENAME, Memc[str], SZ_LINE) + call printf ("\nImage: %s Output: %s\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[str]) + call printf ("Detection Parameters\n") + call printf ( + " Hwhmpsf: %0.3f (pixels) Threshold: %g (ADU) Npixmin: %d\n") + call pargr (SF_HWHMPSF(sf)) + call pargr (SF_THRESHOLD(sf)) + call pargi (SF_NPIXMIN(sf)) + call printf (" Datamin: %g (ADU) Datamax: %g (ADU)\n") + call pargr (SF_DATAMIN(sf)) + call pargr (SF_DATAMAX(sf)) + call printf (" Fradius: %0.3f (HWHM) Sepmin: %0.3f (HWHM)\n\n") + call pargr (SF_FRADIUS(sf)) + call pargr (SF_SEPMIN(sf)) + } + + if (out != NULL) { + call fstats (out, F_FILENAME, Memc[str], SZ_LINE) + call fprintf (out, "\n# Image: %s Output: %s\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[str]) + call fprintf (out, "# Detection Parameters\n") + call fprintf (out, + "# Hwhmpsf: %0.3f (pixels) Threshold: %g (ADU) Npixmin: %d\n") + call pargr (SF_HWHMPSF(sf)) + call pargr (SF_THRESHOLD(sf)) + call pargi (SF_NPIXMIN(sf)) + call fprintf (out, "# Datamin: %g (ADU) Datamax: %g (ADU)\n") + call pargr (SF_DATAMIN(sf)) + call pargr (SF_DATAMAX(sf)) + call fprintf (out, "# Fradius: %g (HWHM) Sepmin: %g (HWHM)\n") + call pargr (SF_FRADIUS(sf)) + call pargr (SF_SEPMIN(sf)) + call fprintf (out, "# Selection Parameters\n") + call pargi (SF_NPIXMIN(sf)) + call fprintf (out, "# Maglo: %0.3f Maghi: %0.3f\n") + call pargr (SF_MAGLO(sf)) + call pargr (SF_MAGHI(sf)) + call fprintf (out, "# Roundlo: %0.3f Roundhi: %0.3f\n") + call pargr (SF_ROUNDLO(sf)) + call pargr (SF_ROUNDHI(sf)) + call fprintf (out, "# Sharplo: %0.3f Sharphi: %0.3f\n") + call pargr (SF_SHARPLO(sf)) + call pargr (SF_SHARPHI(sf)) + call fprintf (out, "# Columns\n") + call fprintf (out, "# 1: X 2: Y \n") + if (ct == NULL) { + call fprintf (out, "# 3: Mag 4: Area\n") + call fprintf (out, "# 5: Hwhm 6: Roundness\n") + call fprintf (out, "# 7: Pa 8: Sharpness\n\n") + } else { + call fprintf (out, "# 3: Wx 4: Wy \n") + call fprintf (out, "# 5: Mag 6: Area\n") + call fprintf (out, "# 7: Hwhm 8: Roundness\n") + call fprintf (out, "# 9: Pa 10: Sharpness\n\n") + } + } + + # Process the image block by block. + stid = 1 + nstars = 0 + do j = 1, IM_LEN(im,2), nyb { + + l1 = j + l2 = min (IM_LEN(im,2), j + nyb - 1) + nlines = l2 - l1 + 1 + 2 * (fwidth / 2 + swidth) + + do i = 1, IM_LEN(im,1), nxb { + + # Allocate space for the convolution kernel. + call malloc (gker2d, fwidth * fwidth, TY_REAL) + call malloc (ngker2d, fwidth * fwidth, TY_REAL) + call malloc (skip, fwidth * fwidth, TY_INT) + + # Allocate space for the data and the convolution. + c1 = i + c2 = min (IM_LEN(im,1), i + nxb - 1) + ncols = c2 - c1 + 1 + 2 * (fwidth / 2 + swidth) + call malloc (imbuf, ncols * nlines, TY_REAL) + call malloc (denbuf, ncols * nlines, TY_REAL) + + # Compute the convolution kernels. + relerr = sf_egkernel (Memr[gker2d], Memr[ngker2d], Memi[skip], + fwidth, fwidth, gsums, a, b, c, f) + + # Do the convolution. + if (norm == YES) + call sf_fconvolve (im, c1, c2, l1, l2, swidth, Memr[imbuf], + Memr[denbuf], ncols, nlines, Memr[ngker2d], Memi[skip], + fwidth, fwidth) + else + call sf_gconvolve (im, c1, c2, l1, l2, swidth, Memr[imbuf], + Memr[denbuf], ncols, nlines, Memr[gker2d], Memi[skip], + fwidth, fwidth, gsums, dmin, dmax) + + # Find the stars. + nstars = sf_stfind (out, Memr[imbuf], Memr[denbuf], ncols, + nlines, c1, c2, l1, l2, swidth, Memi[skip], fwidth, + fwidth, SF_HWHMPSF(sf), SF_THRESHOLD(sf), dmin, dmax, + ct, SF_NPIXMIN(sf), maglo, maghi, SF_ROUNDLO(sf), + SF_ROUNDHI(sf), SF_SHARPLO(sf), SF_SHARPHI(sf), + Memc[fmtstr], stid, verbose) + + # Increment the sequence number. + stid = stid + nstars + + # Free the memory. + call mfree (imbuf, TY_REAL) + call mfree (denbuf, TY_REAL) + call mfree (gker2d, TY_REAL) + call mfree (ngker2d, TY_REAL) + call mfree (skip, TY_INT) + } + } + + # Print out the selection parameters. + if (verbose == YES) { + call printf ("\nSelection Parameters\n") + call printf ( " Maglo: %0.3f Maghi: %0.3f\n") + call pargr (SF_MAGLO(sf)) + call pargr (SF_MAGHI(sf)) + call printf ( " Roundlo: %0.3f Roundhi: %0.3f\n") + call pargr (SF_ROUNDLO(sf)) + call pargr (SF_ROUNDHI(sf)) + call printf ( " Sharplo: %0.3f Sharphi: %0.3f\n") + call pargr (SF_SHARPLO(sf)) + call pargr (SF_SHARPHI(sf)) + } + + if (mw != NULL) { + call mw_ctfree (ct) + call mw_close (mw) + } + call sfree (sp) +end + + +# SF_STFIND -- Detect images in the convolved image and then compute image +# characteristics using the original image. + +int procedure sf_stfind (out, imbuf, denbuf, ncols, nlines, c1, c2, l1, l2, + sepmin, skip, nxk, nyk, hwhmpsf, threshold, datamin, datamax, + ct, nmin, maglo, maghi, roundlo, roundhi, sharplo, sharphi, + fmtstr, stid, verbose) + +int out #I the output file descriptor +real imbuf[ncols,nlines] #I the input data buffer +real denbuf[ncols,nlines] #I the input density enhancements buffer +int ncols, nlines #I the dimensions of the input buffers +int c1, c2 #I the image columns limits +int l1, l2 #I the image lines limits +int sepmin #I the minimum object separation +int skip[nxk,ARB] #I the pixel fitting array +int nxk, nyk #I the dimensions of the fitting array +real hwhmpsf #I the HWHM of the PSF in pixels +real threshold #I the threshold for object detection +real datamin, datamax #I the minimum and maximum good data values +pointer ct #I the coordinate transformation pointer +int nmin #I the minimum number of good object pixels +real maglo,maghi #I the magnitude estimate limits +real roundlo,roundhi #I the ellipticity estimate limits +real sharplo, sharphi #I the sharpness estimate limits +char fmtstr[ARB] #I the format string +int stid #U the object sequence number +int verbose #I verbose mode + +int line1, line2, inline, xmiddle, ymiddle, ntotal, nobjs, nstars +pointer sp, cols, sharp, x, y, ellip, theta, npix, mag, size +int sf_detect(), sf_test() + +begin + # Set up useful line and column limits. + line1 = 1 + sepmin + nyk / 2 + line2 = nlines - sepmin - nyk / 2 + xmiddle = 1 + nxk / 2 + ymiddle = 1 + nyk / 2 + + # Set up a cylindrical buffers and some working space for + # the detected images. + call smark (sp) + call salloc (cols, ncols, TY_INT) + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (mag, ncols, TY_REAL) + call salloc (npix, ncols, TY_INT) + call salloc (size, ncols, TY_REAL) + call salloc (ellip, ncols, TY_REAL) + call salloc (theta, ncols, TY_REAL) + call salloc (sharp, ncols, TY_REAL) + + # Generate the starlist line by line. + ntotal = 0 + do inline = line1, line2 { + + # Detect local maximum in the density enhancement buffer. + nobjs = sf_detect (denbuf[1,inline-nyk/2-sepmin], ncols, sepmin, + nxk, nyk, threshold, Memi[cols]) + if (nobjs <= 0) + next + + # Do not skip the middle pixel in the moments computation. + call sf_moments (imbuf[1,inline-nyk/2], denbuf[1,inline-nyk/2], + ncols, skip, nxk, nyk, Memi[cols], Memr[x], Memr[y], + Memi[npix], Memr[mag], Memr[size], Memr[ellip], Memr[theta], + Memr[sharp], nobjs, datamin, datamax, threshold, hwhmpsf, + real (-sepmin - nxk / 2 + c1 - 1), real (inline - sepmin - + nyk + l1 - 1)) + + # Test the image characeteristics of detected objects. + nstars = sf_test (Memi[cols], Memr[x], Memr[y], Memi[npix], + Memr[mag], Memr[size], Memr[ellip], Memr[theta], Memr[sharp], + nobjs, real (c1 - 0.5), real (c2 + 0.5), real (l1 - 0.5), + real (l2 + 0.5), nmin, maglo, maghi, roundlo, roundhi, + sharplo, sharphi) + + # Print results on the standard output. + if (verbose == YES) + call sf_write (STDOUT, Memi[cols], Memr[x], Memr[y], + Memr[mag], Memi[npix], Memr[size], Memr[ellip], + Memr[theta], Memr[sharp], nstars, ct, fmtstr, + ntotal + stid) + + # Save the results in the file. + call sf_write (out, Memi[cols], Memr[x], Memr[y], Memr[mag], + Memi[npix], Memr[size], Memr[ellip], Memr[theta], + Memr[sharp], nstars, ct, fmtstr, ntotal + stid) + + ntotal = ntotal + nstars + + } + + # Free space + call sfree (sp) + + return (ntotal) +end + + +# SF_DETECT -- Detect stellar objects in an image line. In order to be +# detected as a star the candidate object must be above threshold and have +# a maximum pixel value greater than any pixels within sepmin pixels. + +int procedure sf_detect (density, ncols, sepmin, nxk, nyk, threshold, cols) + +real density[ncols, ARB] #I the input density enhancements array +int ncols #I the x dimension of the input array +int sepmin #I the minimum separation in pixels +int nxk, nyk #I size of the fitting area +real threshold #I density threshold +int cols[ARB] #O column numbers of detected stars + +int i, j, k, ymiddle, nxhalf, nyhalf, ny, b2, nobjs, rj2, r2 +define nextpix_ 11 + +begin + ymiddle = 1 + nyk / 2 + sepmin + nxhalf = nxk / 2 + nyhalf = nyk / 2 + ny = 2 * sepmin + 1 + b2 = sepmin ** 2 + + # Loop over all the columns in an image line. + nobjs = 0 + for (i = 1 + nxhalf + sepmin; i <= ncols - nxhalf - sepmin; ) { + + # Test whether the density enhancement is above threshold. + if (density[i,ymiddle] < threshold) + goto nextpix_ + + # Test whether a given density enhancement satisfies the + # separation criterion. + do j = 1, ny { + rj2 = (j - sepmin - 1) ** 2 + do k = i - sepmin, i + sepmin { + r2 = (i - k) ** 2 + rj2 + if (r2 <= b2) { + if (density[i,ymiddle] < density[k,j+nyhalf]) + goto nextpix_ + } + } + } + + # Add the detected object to the list. + nobjs = nobjs + 1 + cols[nobjs] = i + + # If a local maximum is detected there can be no need to + # check pixels in this row between i and i + sepmin. + i = i + sepmin +nextpix_ + # Work on the next pixel. + i = i + 1 + } + + return (nobjs) +end + + +# SF_MOMENTS -- Perform a moments analysis on the dectected objects. + +procedure sf_moments (data, den, ncols, skip, nxk, nyk, cols, x, y, + npix, mag, size, ellip, theta, sharp, nobjs, datamin, datamax, + threshold, hwhmpsf, xoff, yoff) + +real data[ncols,ARB] #I the input data array +real den[ncols,ARB] #I the input density enhancements array +int ncols #I the x dimension of the input buffer +int skip[nxk,ARB] #I the input fitting array +int nxk, nyk #I the dimensions of the fitting array +int cols[ARB] #I the input initial positions +real x[ARB] #O the output x coordinates +real y[ARB] #O the output y coordinates +int npix[ARB] #O the output area in number of pixels +real mag[ARB] #O the output magnitude estimates +real size[ARB] #O the output size estimates +real ellip[ARB] #O the output ellipticity estimates +real theta[ARB] #O the output position angle estimates +real sharp[ARB] #O the output sharpness estimates +int nobjs #I the number of objects +real datamin, datamax #I the minium and maximum good data values +real threshold #I threshold for moments computation +real hwhmpsf #I the HWHM of the PSF +real xoff, yoff #I the x and y coordinate offsets + +int i, j, k, xmiddle, ymiddle, sumn +double pixval, sumix, sumiy, sumi, sumixx, sumixy, sumiyy, r2, dx, dy, diff +double mean + +begin + # Initialize + xmiddle = 1 + nxk / 2 + ymiddle = 1 + nyk / 2 + + # Compute the pixel sum, number of pixels, and the x and y centers. + do i = 1, nobjs { + + # Estimate the background using the input data and the + # best fitting Gaussian amplitude + sumn = 0 + sumi = 0.0 + do j = 1, nyk { + do k = 1, nxk { + if (skip[k,j] == NO) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + sumi = sumi + pixval + sumn = sumn + 1 + } + } + if (sumn <= 0) + mean = data[cols[i],ymiddle] - den[cols[i],ymiddle] + else + mean = sumi / sumn + + # Compute the first order moments. + sumi = 0.0 + sumn = 0 + sumix = 0.0d0 + sumiy = 0.0d0 + do j = 1, nyk { + do k = 1, nxk { + if (skip[k,j] == YES) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + pixval = pixval - mean + if (pixval <= 0.0) + next + sumi = sumi + pixval + sumix = sumix + (cols[i] - xmiddle + k) * pixval + sumiy = sumiy + j * pixval + sumn = sumn + 1 + } + + } + + # Use the first order moments to estimate the positions + # magnitude, area, and amplitude of the object. + if (sumi <= 0.0) { + x[i] = cols[i] + y[i] = (1.0 + nyk) / 2.0 + mag[i] = INDEFR + npix[i] = 0 + } else { + x[i] = sumix / sumi + y[i] = sumiy / sumi + mag[i] = -2.5 * log10 (sumi) + npix[i] = sumn + } + + # Compute the second order central moments using the results of + # the first order moment analysis. + sumixx = 0.0d0 + sumiyy = 0.0d0 + sumixy = 0.0d0 + do j = 1, nyk { + dy = j - y[i] + do k = 1, nxk { + if (skip[k,j] == YES) + next + pixval = data[cols[i]-xmiddle+k,j] + if (pixval < datamin || pixval > datamax) + next + pixval = pixval - mean + if (pixval <= 0.0) + next + dx = cols[i] - xmiddle + k - x[i] + sumixx = sumixx + pixval * dx ** 2 + sumixy = sumixy + pixval * dx * dy + sumiyy = sumiyy + pixval * dy ** 2 + } + } + + # Use the second order central moments to estimate the size, + # ellipticity, position angle, and sharpness of the objects. + if (sumi <= 0.0) { + size[i] = 0.0 + ellip[i] = 0.0 + theta[i] = 0.0 + sharp[i] = INDEFR + } else { + sumixx = sumixx / sumi + sumixy = sumixy / sumi + sumiyy = sumiyy / sumi + r2 = sumixx + sumiyy + if (r2 <= 0.0) { + size[i] = 0.0 + ellip[i] = 0.0 + theta[i] = 0.0 + sharp[i] = INDEFR + } else { + size[i] = sqrt (LN_2 * r2) + sharp[i] = size[i] / hwhmpsf + diff = sumixx - sumiyy + ellip[i] = sqrt (diff ** 2 + 4.0d0 * sumixy ** 2) / r2 + if (diff == 0.0d0 && sumixy == 0.0d0) + theta[i] = 0.0 + else + theta[i] = RADTODEG (0.5d0 * atan2 (2.0d0 * sumixy, + diff)) + if (theta[i] < 0.0) + theta[i] = theta[i] + 180.0 + } + } + + # Convert the computed coordinates to the image system. + x[i] = x[i] + xoff + y[i] = y[i] + yoff + } +end + + +# SF_TEST -- Check that the detected objects are in the image, contain +# enough pixels above background to be measurable objects, and are within +# the specified magnitude, roundness and sharpness range. + +int procedure sf_test (cols, x, y, npix, mag, size, ellip, theta, sharps, + nobjs, c1, c2, l1, l2, nmin, maglo, maghi, roundlo, roundhi, + sharplo, sharphi) + +int cols[ARB] #U the column ids of detected object +real x[ARB] #U the x position estimates +real y[ARB] #U the y positions estimates +int npix[ARB] #U the area estimates +real mag[ARB] #U the magnitude estimates +real size[ARB] #U the size estimates +real ellip[ARB] #U the ellipticity estimates +real theta[ARB] #U the position angle estimates +real sharps[ARB] #U sharpness estimates +int nobjs #I the number of detected objects +real c1, c2 #I the image column limits +real l1, l2 #I the image line limits +int nmin #I the minimum area +real maglo, maghi #I the magnitude limits +real roundlo, roundhi #I the roundness limits +real sharplo, sharphi #I the sharpness limits + +int i, nstars + +begin + # Loop over the detected objects. + nstars = 0 + do i = 1, nobjs { + + if (x[i] < c1 || x[i] > c2) + next + if (y[i] < l1 || y[i] > l2) + next + if (npix[i] < nmin) + next + if (mag[i] < maglo || mag[i] > maghi) + next + if (ellip[i] < roundlo || ellip[i] > roundhi) + next + if (! IS_INDEFR(sharps[i]) && (sharps[i] < sharplo || + sharps[i] > sharphi)) + next + + # Add object to the list. + nstars = nstars + 1 + cols[nstars] = cols[i] + x[nstars] = x[i] + y[nstars] = y[i] + mag[nstars] = mag[i] + npix[nstars] = npix[i] + size[nstars] = size[i] + ellip[nstars] = ellip[i] + theta[nstars] = theta[i] + sharps[nstars] = sharps[i] + } + + return (nstars) +end + + +# SF_WRITE -- Write the results to the output file. + +procedure sf_write (fd, cols, x, y, mag, npix, size, ellip, theta, sharp, + nstars, ct, fmtstr, stid) + +int fd #I the output file descriptor +int cols[ARB] #I column numbers +real x[ARB] #I xcoords +real y[ARB] #I y coords +real mag[ARB] #I magnitudes +int npix[ARB] #I number of pixels +real size[ARB] #I object sizes +real ellip[ARB] #I ellipticities +real theta[ARB] #I position angles +real sharp[ARB] #I sharpnesses +int nstars #I number of detected stars in the line +pointer ct #I coordinate transformation +char fmtstr[ARB] #I the output format string +int stid #I output file sequence number + +double lx, ly, wx, wy +int i + +begin + if (fd == NULL) + return + + do i = 1, nstars { + call fprintf (fd, fmtstr) + call pargr (x[i]) + call pargr (y[i]) + if (ct != NULL) { + lx = x[i] + ly = y[i] + call mw_c2trand (ct, lx, ly, wx, wy) + call pargd (wx) + call pargd (wy) + } + call pargr (mag[i]) + call pargi (npix[i]) + call pargr (size[i]) + call pargr (ellip[i]) + call pargr (theta[i]) + call pargr (sharp[i]) + call pargi (stid + i - 1) + } +end diff --git a/pkg/images/imcoords/src/sftools.x b/pkg/images/imcoords/src/sftools.x new file mode 100644 index 00000000..02bec379 --- /dev/null +++ b/pkg/images/imcoords/src/sftools.x @@ -0,0 +1,68 @@ +include +include "starfind.h" + +# SF_GPARS-- Read in the star finding parameters from the datapars file. + +procedure sf_gpars (sf) + +pointer sf #I pointer to the star finding structure + +int clgeti() +real clgetr() + +begin + # Initialize the data structure. + call sf_init (sf) + + # Fetch the star finding parameters. + SF_HWHMPSF(sf) = clgetr ("hwhmpsf") + SF_FRADIUS(sf) = clgetr ("fradius") + SF_THRESHOLD(sf) = clgetr ("threshold") + SF_DATAMIN(sf) = clgetr ("datamin") + SF_DATAMAX(sf) = clgetr ("datamax") + SF_SEPMIN(sf) = clgetr ("sepmin") + SF_NPIXMIN(sf) = clgeti ("npixmin") + SF_MAGLO(sf) = clgetr ("maglo") + SF_MAGHI(sf) = clgetr ("maghi") + SF_ROUNDLO(sf) = clgetr ("roundlo") + SF_ROUNDHI(sf) = clgetr ("roundhi") + SF_SHARPLO(sf) = clgetr ("sharplo") + SF_SHARPHI(sf) = clgetr ("sharphi") +end + + +# SF_INIT -- Initialize the STARFIND task data structure and set the +# star finding parameters to their default values. + +procedure sf_init (sf) + +pointer sf #U pointer to the star finding structure + +begin + call calloc (sf, LEN_STARFIND, TY_STRUCT) + + SF_HWHMPSF(sf) = DEF_HWHMPSF + SF_FRADIUS(sf) = DEF_FRADIUS + SF_THRESHOLD(sf) = DEF_THRESHOLD + SF_DATAMIN(sf) = DEF_DATAMIN + SF_DATAMAX(sf) = DEF_DATAMAX + SF_SHARPLO(sf) = DEF_SHARPLO + SF_SHARPHI(sf) = DEF_SHARPHI + SF_ROUNDLO(sf) = DEF_ROUNDLO + SF_ROUNDHI(sf) = DEF_ROUNDHI + SF_MAGLO(sf) = DEF_MAGLO + SF_MAGHI(sf) = DEF_MAGHI + SF_SEPMIN(sf) = DEF_SEPMIN + SF_NPIXMIN(sf) = DEF_NPIXMIN +end + + +# SF_FREE -- Free the STARFIND task data structure. + +procedure sf_free (sf) + +pointer sf #U pointer to the star finding structure + +begin + call mfree (sf, TY_STRUCT) +end diff --git a/pkg/images/imcoords/src/skyctran.x b/pkg/images/imcoords/src/skyctran.x new file mode 100644 index 00000000..22d182e6 --- /dev/null +++ b/pkg/images/imcoords/src/skyctran.x @@ -0,0 +1,2057 @@ +include +include +include +include + +define HELPFILE1 "imcoords$src/skycur.key" +define HELPFILE2 "imcoords$src/ttycur.key" + +define CURCMDS "|show|isystem|osystem||ounits|oformats|" +define TYPECMDS "|show|isystem|osystem|iunits|ounits|oformats|" + +define CCMD_SHOW 1 +define CCMD_ISYSTEM 2 +define CCMD_OSYSTEM 3 +define CCMD_IUNITS 4 +define CCMD_OUNITS 5 +define CCMD_OFORMATS 6 + + +# SK_TTYTRAN -- Transform the typed coordinate list. + +procedure sk_ttytran (infd, outfd, mwin, mwout, cooin, cooout, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat) + +int infd #I the input file descriptor +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format + +double ilng, ilat, pilng, pilat, px, rv, tlng, tlat, olng, olat +int newsystem, newformat, newobject, tilngunits, tilatunits, tolngunits +int tolatunits, ip, key +pointer ctin, ctout, sp, cmd, fmtstr, tolngformat, tolatformat, str1, str2 +double sl_da1p() +int scan(), nscan(), sk_stati(), ctod() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Initialize. + newsystem = YES + newformat = YES + newobject = NO + ctin = NULL + ctout = NULL + + # Get some working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + + # Loop over the input. + while (scan() != EOF) { + call gargstr (Memc[cmd], SZ_LINE) + key = Memc[cmd] + switch (key) { + + case '?': + call pagefile (HELPFILE2, "[space=cmhelp,q=quit,?=help]") + + case 'q': + break + + case ':': + call sk_ccolon (infd, outfd, cooin, cooout, mwin, mwout, + ilngunits, ilatunits, olngunits, olatunits, olngformat, + olatformat, Memc[cmd+1], TYPECMDS, newsystem, newformat) + + default: + newobject = YES + } + + if (newobject == NO) + next + + # Decode the input coordinates. + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (nscan() < 2) + next + ip = 1 + if (ctod (Memc[str1], ip, ilng) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, ilat) <= 0) + next + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + + + # Decode the proper motions. + if (nscan() < 4) { + pilng = INDEFD + pilat = INDEFD + } else { + ip = 1 + if (ctod (Memc[str1], ip, pilng) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, pilat) <= 0) + next + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } + } + + # Decode the parallax and radial velocity + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (nscan() < 6) { + px = 0.0d0 + rv = 0.0d0 + } else { + ip = 1 + if (ctod (Memc[str1], ip, px) <= 0) + next + ip = 1 + if (ctod (Memc[str2], ip, rv) <= 0) + next + if (IS_INDEFD(px)) + px = 0.0d0 + if (IS_INDEFD(rv)) + rv = 0.0d0 + } + + # Compile the mwcs transformation. + if (newsystem == YES) { + if (ctin != NULL) + call mw_ctfree (cooin) + if (ctout != NULL) + call mw_ctfree (cooout) + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then { + ctin = NULL + ctout = NULL + } + newsystem = NO + } + + # Set the input and output coordinate units and the output format. + if (newformat == YES) { + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], + Memc[tolatformat], SZ_FNAME) + call sk_iunits (cooin, mwin, tilngunits, tilatunits, + tilngunits, tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, + tolngunits, tolatunits) + call sprintf (Memc[fmtstr], SZ_LINE, "%%s %s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + newformat = NO + } + + # Perform the coordinate transformation. + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati (cooout, + S_STATUS) == ERR) { + + olng = ilng + olat = ilat + + } else { + + # Compute the input coordinate to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Convert the proper motions to the correct units. + if (!IS_INDEFD(pilng) && !IS_INDEFD(pilat)) { + pilng = DEGTORAD(pilng * 15.0d0 / 3600.0d0) + pilat = DEGTORAD(pilat / 3600.0d0) + call sl_dtps (pilng / 15.0d0, pilat, 0.0d0, olat, pilng, + pilat) + pilng = sl_da1p (pilng) + pilat = pilat - olat + } else { + pilng = INDEFD + pilat = INDEFD + } + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, pilng, pilat, px, + rv, tlng, tlat) + + # Convert the celestial coordinates in radians to the output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + } + + # Write the results. + call fprintf (outfd, Memc[fmtstr]) + call pargstr (Memc[cmd]) + call pargd (olng) + call pargd (olat) + if (outfd != STDOUT) { + call printf (Memc[fmtstr]) + call pargstr (Memc[cmd]) + call pargd (olng) + call pargd (olat) + } + + newobject = NO + } + + call sfree (sp) +end + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# SK_LISTRAN -- Transform the coordinate list. + +procedure sk_listran (infd, outfd, mwin, mwout, cooin, cooout, lngcolumn, + latcolumn, plngcolumn, platcolumn, pxcolumn, rvcolumn, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat, + min_sigdigits, transform) + +int infd #I the input file descriptor +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +int plngcolumn #I the input ra/longitude pm column +int platcolumn #I the input dec/latitude pm column +int pxcolumn #I the input parallax column +int rvcolumn #I the input radial column +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +int min_sigdigits #I the minimum number of significant digits +bool transform #I transform the input file + +double ilng, ilat, tlng, tlat, olng, olat, pilng, pilat, px, rv +int nline, ip, max_fields, nfields, offset, nchars, nsdig_lng, nsdig_lat +int tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ctin, ctout +pointer tolngformat, tolatformat +double sl_da1p() +int sk_stati(), li_get_numd(), getline() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input abd output transformations. + # coordinate units. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Allocate some memory. + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the default input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the output format. + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Loop over the input coordinates. + max_fields = MAX_FIELDS + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Check for blank lines and comment lines. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + if (lngcolumn > nfields || latcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Get the proper motions. + if (! IS_INDEFI(plngcolumn) && ! IS_INDEFI(platcolumn)) { + if (plngcolumn > nfields || platcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+plngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], pilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad pm value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+platcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], pilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad pm value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } + } else { + pilng = INDEFD + pilat = INDEFD + } + + # Get the parallax value. + if (! IS_INDEFI(pxcolumn)) { + if (pxcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+pxcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], px, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Bad parallax value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(px)) + px = 0.0d0 + } else + px = 0.0d0 + + # Get the parallax value. + if (! IS_INDEFI(rvcolumn)) { + if (rvcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+rvcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], rv, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Bad radial velocity value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + if (IS_INDEFD(rv)) + rv = 0.0d0 + } else + rv = 0.0d0 + + # Convert the input coordinates to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Convert the proper motions to the correct units. + if (IS_INDEFD(pilng) || IS_INDEFD(pilat)) { + pilng = INDEFD + pilat = INDEFD + } else { + pilng = DEGTORAD(pilng * 15.0d0 / 3600.0d0) + pilat = DEGTORAD(pilat / 3600.0d0) + call sl_dtps (pilng / 15.0d0, pilat, 0.0d0, olat, pilng, pilat) + pilng = sl_da1p (pilng) + pilat = pilat - olat + } + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, pilng, pilat, + px, rv, tlng, tlat) + + # Convert the output celestial coordinates from radians to output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Output the results. + if (transform) { + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, lngcolumn, latcolumn, olng, + olat, Memc[tolngformat], Memc[tolatformat], nsdig_lng, + nsdig_lat, min_sigdigits) + } else { + call li_append_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + olng, olat, Memc[tolngformat], Memc[tolatformat], + nsdig_lng, nsdig_lat, min_sigdigits) + } + call putline (outfd, Memc[outbuf]) + } + + call sfree (sp) +end + + +# SK_COPYTRAN -- Copy the input coordinate file to the output coordinate file. + +procedure sk_copytran (infd, outfd, lngcolumn, latcolumn, transform) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +bool transform #I tranform the input file + +double ilng, ilat +int ip, nline, max_fields, nfields, xoffset, yoffset, nchars +int nsdig_lng, nsdig_lat, xwidth, ywidth +pointer sp, inbuf, linebuf, outbuf, field_pos +int getline(), li_get_numd() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + + if (transform) { + while (getline (infd, Memc[inbuf]) != EOF) + call putline (outfd, Memc[inbuf]) + } else { + max_fields = MAX_FIELDS + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; + nline = nline + 1) { + + # Check for blank lines and comment lines. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], + max_fields, nfields) + + if (lngcolumn > nfields || latcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + xoffset = Memi[field_pos+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+xoffset-1], ilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + xwidth = Memi[field_pos+lngcolumn] - Memi[field_pos+lngcolumn-1] + + yoffset = Memi[field_pos+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+yoffset-1], ilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + ywidth = Memi[field_pos+latcolumn] - Memi[field_pos+latcolumn-1] + + call li_cappend_line (Memc[linebuf], Memc[outbuf], SZ_LINE, + xoffset, yoffset, xwidth, ywidth) + call putline (outfd, Memc[outbuf]) + } + } + + call sfree (sp) +end + + +# SK_CURTRAN -- Transform the cursor coordinate list. + +procedure sk_curtran (outfd, mwin, mwout, cooin, cooout, olngunits, olatunits, + olngformat, olatformat, transform) + +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +bool transform #I transform the input file + +double ilng, ilat, tlng, tlat, olng, olat +int wcs, key, tolngunits, tolatunits, newsystem, newformat, newobject +int ijunk +pointer sp, cmd, fmtstr, ctin, ctout, tolngformat, tolatformat +real wx, wy +int clgcur(), sk_stati() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Initialize. + newsystem = YES + newformat = YES + newobject = NO + ctin = NULL + ctout = NULL + + # Get some working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + while (clgcur ("icommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + + newobject = NO + ilng = wx + ilat = wy + + switch (key) { + + case '?': + call pagefile (HELPFILE1, "[space=cmhelp,q=quit,?=help]") + + case 'q': + break + + case ':': + call sk_ccolon (NULL, outfd, cooin, cooout, mwin, mwout, + ijunk, ijunk, olngunits, olatunits, olngformat, + olatformat, Memc[cmd], CURCMDS, newsystem, newformat) + + case ' ': + newobject = YES + + default: + ; + } + + if (newobject == NO) + next + + # Compile the mwcs transformation. + if (newsystem == YES) { + if (ctin != NULL) + call mw_ctfree (ctin) + if (ctout != NULL) + call mw_ctfree (ctout) + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then { + ctin = NULL + ctout = NULL + } + newsystem = NO + } + + # Set the output coordinates units and format. + if (newformat == YES) { + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], + Memc[tolatformat], SZ_FNAME) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, + tolngunits, tolatunits) + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati(cooout, + S_STATUS) == ERR) { + if (transform) + call strcpy ("%10.3f %10.3f\n", Memc[fmtstr], SZ_LINE) + else + call strcpy ("%10.3f %10.3f %10.3f %10.3f\n", + Memc[fmtstr], SZ_LINE) + } else { + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, + "%%10.3f %%10.3f %s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + } + newformat = NO + } + + # Compute the transformation. + if (sk_stati(cooin, S_STATUS) == ERR || sk_stati(cooout, + S_STATUS) == ERR) { + olng = ilng + olat = ilat + } else { + call sk_incc (cooin, mwin, ctin, SKY_DEGREES, SKY_DEGREES, + ilng, ilat, olng, olat) + call sk_lltran (cooin, cooout, olng, olat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tlng, tlat) + call sk_outcc (cooout, mwout, ctout, tolngunits, + tolatunits, tlng, tlat, olng, olat) + } + + # Write out the results. + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (olng) + call pargd (olat) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargr (wx) + call pargr (wy) + call pargd (olng) + call pargd (olat) + } + + newobject = NO + + } + + call sfree (sp) +end + +# SKY_CCOLON -- Process image cursor colon commands. + +procedure sk_ccolon (infd, outfd, cooin, cooout, mwin, mwout, ilngunits, + ilatunits, olngunits, olatunits, olngformat, olatformat, cmdstr, + cmdlist, newsystem, newformat) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +pointer cooin #U the input coordinate descriptor +pointer cooout #U the output coordinate descriptor +pointer mwin #U the input image wcs +pointer mwout #U the output image wcs +int ilngunits #U the input ra/longitude units +int ilatunits #U the input dec/latitude units +int olngunits #U the output ra/longitude units +int olatunits #U the output dec/latitude units +char olngformat[ARB] #U the output ra/longitude format +char olatformat[ARB] #U the output dec/latitude format +char cmdstr[ARB] #I the input command string +char cmdlist[ARB] #I the input command list +int newsystem #U new coordinate system ? +int newformat #U new coordinate format ? + +int ncmd, stat +pointer sp, cmd, str1, str2, str3, str4, tmw, tcoo +int sk_stati(), strdic(), sk_decwcs() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str1, SZ_FNAME, TY_CHAR) + call salloc (str2, SZ_FNAME, TY_CHAR) + call salloc (str3, SZ_FNAME, TY_CHAR) + call salloc (str4, SZ_FNAME, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, cmdlist) + call gargstr (Memc[cmd], SZ_LINE) + switch (ncmd) { + + case CCMD_SHOW: + call fprintf (outfd, "\n") + if (sk_stati (cooin, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Insystem", Memc[str1], mwin, + cooin) + if (infd == NULL) + call sk_wiformats (cooin, ilngunits, ilatunits, "%10.3f", + "%10.3f", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + else + call sk_wiformats (cooin, ilngunits, ilatunits, "INDEF", + "INDEF", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + call fprintf (outfd, "# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + if (sk_stati(cooout, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Outsystem", Memc[str1], mwout, + cooout) + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call fprintf (outfd, "\n") + + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati (cooin, S_STATUS) == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Insystem", Memc[str1], mwin, cooin) + if (infd == NULL) + call sk_wiformats (cooin, ilngunits, ilatunits, "%10.3f", + "%10.3f", Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + else + call sk_wiformats (cooin, ilngunits, ilatunits, "INDEF", + "INDEF", Memc[str1], Memc[str2], Memc[str3], Memc[str4], + SZ_FNAME) + call printf ("# Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + if (sk_stati(cooout, S_STATUS) == ERR) + call printf ( + "Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Outsystem", Memc[str1], mwout, cooout) + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call printf (" Units: %s %s Format: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call printf ("\n") + } + + case CCMD_ISYSTEM: + stat = sk_decwcs (Memc[cmd], tmw, tcoo, NULL) + if (Memc[cmd] == EOS || stat == ERR || (infd == NULL && + tmw == NULL)) { + if (tmw != NULL) + call mw_close (tmw) + call sk_close (tcoo) + call fprintf (outfd, "\n") + if (sk_stati(cooin, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Insystem", Memc[str1], mwin, cooin) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati(cooin, S_STATUS) == ERR) + call printf ( + "# Error decoding the input coordinate system\n") + call sk_stats (cooin, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Insystem", Memc[str1], mwin, cooin) + call printf ("\n") + } + } else { + if (mwin != NULL) + call mw_close (mwin) + call sk_close (cooin) + mwin = tmw + cooin = tcoo + if (infd == NULL) + call sk_seti (cooin, S_PIXTYPE, PIXTYPE_TV) + newsystem = YES + newformat = YES + } + + case CCMD_OSYSTEM: + stat = sk_decwcs (Memc[cmd], tmw, tcoo, NULL) + if (Memc[cmd] == EOS || stat == ERR) { + if (tmw != NULL) + call mw_close (tmw) + call sk_close (tcoo) + call fprintf (outfd, "\n") + if (sk_stati(cooout, S_STATUS) == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiwrite (outfd, "Outsystem", Memc[str1], mwout, cooout) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + if (sk_stati(cooout, S_STATUS) == ERR) + call printf ( + "# Error decoding the output coordinate system\n") + call sk_stats (cooout, S_COOSYSTEM, Memc[str1], SZ_FNAME) + call sk_iiprint ("Outsystem", Memc[str1], mwout, cooout) + call printf ("\n") + } + } else { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (cooout) + mwout = tmw + cooout = tcoo + newsystem = YES + newformat = YES + } + + case CCMD_IUNITS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_wiformats (cooin, ilngunits, ilatunits, "", "", + Memc[str1], Memc[str2], Memc[str3], Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf ("\n") + } + } else { + ilngunits = strdic (Memc[str1], Memc[str1], SZ_FNAME, + SKY_LNG_UNITLIST) + ilatunits = strdic (Memc[str2], Memc[str2], SZ_FNAME, + SKY_LAT_UNITLIST) + newformat = YES + } + + case CCMD_OUNITS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Units: %s %s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf ("\n") + } + } else { + olngunits = strdic (Memc[str1], Memc[str1], SZ_FNAME, + SKY_LNG_UNITLIST) + olatunits = strdic (Memc[str2], Memc[str2], SZ_FNAME, + SKY_LAT_UNITLIST) + newformat = YES + } + + case CCMD_OFORMATS: + call sscan (Memc[cmd]) + call gargwrd (Memc[str1], SZ_FNAME) + call gargwrd (Memc[str2], SZ_FNAME) + if (Memc[cmd] == EOS) { + call sk_woformats (cooin, cooout, olngunits, olatunits, + olngformat, olatformat, Memc[str1], Memc[str2], Memc[str3], + Memc[str4], SZ_FNAME) + call fprintf (outfd, "\n") + call fprintf (outfd, "# Formats: %s %s\n") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call fprintf (outfd, "\n") + if (outfd != STDOUT) { + call printf ("\n") + call printf ("Formats: %s %s\n") + call pargstr (Memc[str3]) + call pargstr (Memc[str4]) + call printf ("\n") + } + } else { + call strcpy (Memc[str1], olngformat, SZ_FNAME) + call strcpy (Memc[str2], olatformat, SZ_FNAME) + newformat = YES + } + + default: + ; + } + + call sfree (sp) +end + + +# SK_GRTRAN -- Transform the grid coordinate list. + +procedure sk_grtran (outfd, mwin, mwout, cooin, cooout, ilngmin, ilngmax, + nilng, ilatmin, ilatmax, nilat, ilngunits, ilatunits, olngunits, + olatunits, ilngformat, ilatformat, olngformat, olatformat, transform) + +int outfd #I the input file descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +double ilngmin #I the x/ra/longitude minimum +double ilngmax #I the x/ra/longitude maximum +int nilng #I the number of x/ra/longitude grid points +double ilatmin #I the y/dec/longitude minimum +double ilatmax #I the y/dec/longitude maximum +int nilat #I the number of y/dec/latitude grid points +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char ilngformat[ARB] #I the input ra/longitude format +char ilatformat[ARB] #I the input dec/latitude format +char olngformat[ARB] #I the output ra/longitude format +char olatformat[ARB] #I the output dec/latitude format +bool transform #I transform the input file + +double ilng1, ilng2, ilat1, ilat2, ilngstep, ilatstep, ilng, ilat, olng, olat +double tlng, tlat +int i, j, tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, fmtstr, ctin, ctout, tilngformat, tilatformat +pointer tolngformat, tolatformat +int sk_stati() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input and output transformations. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Get some working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tilngformat, SZ_FNAME, TY_CHAR) + call salloc (tilatformat, SZ_FNAME, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the input and output formats. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, Memc[tilngformat], Memc[tilatformat], + SZ_FNAME) + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Create the format string. + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s\n") + call pargstr (Memc[tilngformat]) + call pargstr (Memc[tilatformat]) + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + + # Compute the grid parameters in x/ra/longitude. + if (IS_INDEFD(ilngmin)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilng1 = 1.0d0 + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + ilng1 = 1.0d0 + default: + switch (tilngunits) { + case SKY_HOURS: + ilng1 = 0.0d0 + case SKY_DEGREES: + ilng1 = 0.0d0 + case SKY_RADIANS: + ilng1 = 0.0d0 + } + } + } + } else + ilng1 = ilngmin + + if (IS_INDEFD(ilngmax)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilng2 = sk_stati (cooin, S_NLNGAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilng2 = sk_stati(cooin, S_NLNGAX) + default: + switch (tilngunits) { + case SKY_HOURS: + ilng2 = 24.0d0 + case SKY_DEGREES: + ilng2 = 360.0d0 + case SKY_RADIANS: + ilng2 = TWOPI + } + } + } + } else + ilng2 = ilngmax + if (nilng == 1) + ilngstep = 0.0d0 + else + ilngstep = (ilng2 - ilng1) / (nilng - 1) + + # Compute the grid parameters in y/dec/latitude. + if (IS_INDEFD(ilatmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilat1 = 1.0d0 + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilat1 = 1.0d0 + default: + switch (tilatunits) { + case SKY_HOURS: + ilat1 = 0.0d0 + case SKY_DEGREES: + ilat1 = -90.0d0 + case SKY_RADIANS: + ilat1 = -HALFPI + } + } + } + } else + ilat1 = ilatmin + + if (IS_INDEFD(ilatmax)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + ilat2 = sk_stati (cooin, S_NLATAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + ilat2 = sk_stati(cooin, S_NLATAX) + default: + switch (tilatunits) { + case SKY_HOURS: + ilat2 = 24.0d0 + case SKY_DEGREES: + ilat2 = 90.0d0 + case SKY_RADIANS: + ilat2 = HALFPI + } + } + } + } else + ilat2 = ilatmax + if (nilat == 1) + ilatstep = 0.0d0 + else + ilatstep = (ilat2 - ilat1) / (nilat - 1) + + # Compute the grid of points. + do j = 1, nilat { + + ilat = ilat1 + (j - 1) * ilatstep + + do i = 1, nilng { + + ilng = ilng1 + (i - 1) * ilngstep + + # Convert the input coordinates to world coordinates in + # radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, + ilng, ilat, olng, olat) + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, INDEFD, + INDEFD, 0.0d0, 0.0d0, tlng, tlat) + + # Convert the celestial coordinates to output coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Write out the results + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (olng) + call pargd (olat) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargd (ilng) + call pargd (ilat) + call pargd (olng) + call pargd (olat) + } + } + } + + call sfree (sp) +end + + +# SK_GRCOPY -- Copy the input logical pixel grid to the output logical +# pixel grid. + +procedure sk_grcopy (outfd, cooin, cooout, ilngmin, ilngmax, nilng, ilatmin, + ilatmax, nilat, ilngunits, ilatunits, olngunits, olatunits, ilngformat, + ilatformat, olngformat, olatformat, transform) + +int outfd #I the output file descriptor +pointer cooin #I the pointer to input coordinate structure +pointer cooout #I the pointer to output coordinate structure +double ilngmin #I the x/ra/longitude minimum +double ilngmax #I the x/ra/longitude maximum +int nilng #I the number of x/ra/longitude grid points +double ilatmin #I the y/dec/longitude minimum +double ilatmax #I the y/dec/longitude maximum +int nilat #I the number of y/dec/latitude grid points +int ilngunits #I the input x/ra/longitude units +int ilatunits #I the input y/dec/latitude/units +int olngunits #I the output x/ra/longitude units +int olatunits #I the output y/dec/latitude/units +char ilngformat[ARB] #I the input x format string +char ilatformat[ARB] #I the intput y format string +char olngformat[ARB] #I the output x format string +char olatformat[ARB] #I the output y format string +bool transform #I transform the input file + +double x1, x2, x, y1, y2, y, xstep, ystep +int i, j, tilngunits, tilatunits, tolngunits, tolatunits +pointer sp, tilngformat, tilatformat, tolngformat, tolatformat, fmtstr +int sk_stati() + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (tilngformat, SZ_FNAME, TY_CHAR) + call salloc (tilatformat, SZ_FNAME, TY_CHAR) + call salloc (tolngformat, SZ_FNAME, TY_CHAR) + call salloc (tolatformat, SZ_FNAME, TY_CHAR) + + # Set the input units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the input and output formats. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, Memc[tilngformat], Memc[tilatformat], + SZ_FNAME) + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, Memc[tolngformat], Memc[tolatformat], + SZ_FNAME) + + # Create the format string. + if (transform) { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s\n") + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } else { + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s\n") + call pargstr (Memc[tilngformat]) + call pargstr (Memc[tilatformat]) + call pargstr (Memc[tolngformat]) + call pargstr (Memc[tolatformat]) + } + + # Compute the grid parameters in x/ra/longitude. + if (IS_INDEFD(ilngmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + x1 = 1.0d0 + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + x1 = 1.0d0 + default: + switch (tilngunits) { + case SKY_HOURS: + x1 = 0.0d0 + case SKY_DEGREES: + x1 = 0.0d0 + case SKY_RADIANS: + x1 = 0.0d0 + } + } + } + } else + x1 = ilngmin + if (IS_INDEFD(ilngmax)) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + x2 = sk_stati(cooin, S_NLNGAX) + default: + switch (sk_stati (cooin, S_CTYPE)) { + case 0: + x2 = sk_stati (cooin, S_NLNGAX) + default: + switch (tilngunits) { + case SKY_HOURS: + x2 = 24.0d0 + case SKY_DEGREES: + x2 = 360.0d0 + case SKY_RADIANS: + x2 = TWOPI + } + } + } + } else + x2 = ilngmax + if (nilng == 1) + xstep = 0.0d0 + else + xstep = (x2 - x1) / (nilng - 1) + + # Compute the grid parameters in y/dec/latitude. + if (IS_INDEFD(ilatmin)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + y1 = 1.0d0 + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + y1 = 1.0d0 + default: + switch (tilatunits) { + case SKY_HOURS: + y1 = 0.0d0 + case SKY_DEGREES: + y1 = -90.0d0 + case SKY_RADIANS: + y1 = -HALFPI + } + } + } + } else + y1 = ilatmin + + if (IS_INDEFD(ilatmax)) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + y2 = sk_stati (cooin, S_NLATAX) + default: + switch (sk_stati(cooin, S_CTYPE)) { + case 0: + y2 = sk_stati (cooin, S_NLATAX) + default: + switch (tilatunits) { + case SKY_HOURS: + y2 = 24.0d0 + case SKY_DEGREES: + y2 = 90.0d0 + case SKY_RADIANS: + y2 = HALFPI + } + } + } + } else + y2 = ilatmax + if (nilat == 1) + ystep = 0.0d0 + else + ystep = (y2 - y1) / (nilat - 1) + + # Compute the points. + y = y1 + do j = 1, nilat { + x = x1 + do i = 1, nilng { + if (transform) { + call fprintf (outfd, Memc[fmtstr]) + call pargd (x) + call pargd (y) + } else { + call fprintf (outfd, Memc[fmtstr]) + call pargd (x) + call pargd (y) + call pargd (x) + call pargd (y) + } + x = x + xstep + } + y = y + ystep + } + + call sfree (sp) +end + + +# SK_WIFORMATS -- Format the input units and format strings. + +procedure sk_wiformats (cooin, ilngunits, ilatunits, ilngformat, + ilatformat, ilngunitstr, ilatunitstr, oilngformat, oilatformat, maxch) + +pointer cooin #I the input coordinate structure +int ilngunits #I the output ra/longitude units +int ilatunits #I the output dec/latitude units +char ilngformat[ARB] #I the output ra/longitude format string +char ilatformat[ARB] #I the output dec/latitude format string +char ilngunitstr[ARB] #O the output output ra/longitude format string +char ilatunitstr[ARB] #O the output output dec/latitude format string +char oilngformat[ARB] #O the output output ra/longitude format string +char oilatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int tilngunits, tilatunits +int sk_stati() + +begin + # Determine the correct units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + + # Format the units strings. + if (sk_stati(cooin, S_PIXTYPE) != PIXTYPE_WORLD) { + call strcpy ("pixels", ilngunitstr, maxch) + call strcpy ("pixels", ilatunitstr, maxch) + } else { + switch (tilngunits) { + case SKY_HOURS: + call strcpy ("hours", ilngunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", ilngunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", ilngunitstr, maxch) + } + switch (tilatunits) { + case SKY_HOURS: + call strcpy ("hours", ilatunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", ilatunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", ilatunitstr, maxch) + } + } + + # Format the format strings. + call sk_iformats (cooin, ilngformat, ilatformat, + tilngunits, tilatunits, oilngformat, oilatformat, + SZ_FNAME) +end + + +# SK_IFORMATS -- Set the input format strings. + +procedure sk_iformats (cooin, ilngformat, ilatformat, ilngunits, ilatunits, + oilngformat, oilatformat, maxch) + +pointer cooin #I the input coordinate structure +char ilngformat[ARB] #I the input ra/longitude format string +char ilatformat[ARB] #I the input dec/latitude format string +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +char oilngformat[ARB] #O the input ra/longitude format string +char oilatformat[ARB] #O the input dec/latitude format string +int maxch #I the maximum length of the format strings + +int sk_stati() + +begin + if (ilngformat[1] == EOS) { + if (sk_stati(cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oilngformat, maxch) + else { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oilngformat, maxch) + default: + switch (ilngunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oilngformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oilngformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oilngformat, maxch) + } + } + } + } else + call strcpy (ilngformat, oilngformat, maxch) + + if (ilatformat[1] == EOS) { + if (sk_stati (cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oilatformat, maxch) + else { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oilatformat, maxch) + default: + switch (ilatunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oilatformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oilatformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oilatformat, maxch) + } + } + } + } else + call strcpy (ilatformat, oilatformat, maxch) +end + + +# SK_WOFORMATS -- Format the units and format strings. + +procedure sk_woformats (cooin, cooout, olngunits, olatunits, olngformat, + olatformat, olngunitstr, olatunitstr, oolngformat, oolatformat, maxch) + +pointer cooin #I the input coordinate structure +pointer cooout #I the output coordinate structure +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char olngformat[ARB] #I the output ra/longitude format string +char olatformat[ARB] #I the output dec/latitude format string +char olngunitstr[ARB] #O the output output ra/longitude format string +char olatunitstr[ARB] #O the output output dec/latitude format string +char oolngformat[ARB] #O the output output ra/longitude format string +char oolatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int tolngunits, tolatunits +int sk_stati() + +begin + # Determine the correct units. + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Format the units strings. + if (sk_stati(cooout, S_PIXTYPE) != PIXTYPE_WORLD) { + call strcpy ("pixels", olngunitstr, maxch) + call strcpy ("pixels", olatunitstr, maxch) + } else { + switch (tolngunits) { + case SKY_HOURS: + call strcpy ("hours", olngunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", olngunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", olngunitstr, maxch) + } + switch (tolatunits) { + case SKY_HOURS: + call strcpy ("hours", olatunitstr, maxch) + case SKY_DEGREES: + call strcpy ("degrees", olatunitstr, maxch) + case SKY_RADIANS: + call strcpy ("radians", olatunitstr, maxch) + } + } + + # Format the format strings. + call sk_oformats (cooin, cooout, olngformat, olatformat, + tolngunits, tolatunits, oolngformat, oolatformat, + SZ_FNAME) +end + + +# SK_OFORMATS -- Set the output format strings. + +procedure sk_oformats (cooin, cooout, olngformat, olatformat, olngunits, + olatunits, oolngformat, oolatformat, maxch) + +pointer cooin #I the input coordinate structure +pointer cooout #I the output coordinate structure +char olngformat[ARB] #I the output ra/longitude format string +char olatformat[ARB] #I the output dec/latitude format string +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +char oolngformat[ARB] #O the output output ra/longitude format string +char oolatformat[ARB] #O the output output dec/latitude format string +int maxch #I the maximum length of the format strings + +int sptype +int sk_stati() + +begin + if (olngformat[1] == EOS) { + if (sk_stati(cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oolngformat, maxch) + else { + if (sk_stati(cooout, S_STATUS) == ERR) + sptype = sk_stati (cooin, S_PIXTYPE) + else + sptype = sk_stati (cooout, S_PIXTYPE) + switch (sptype) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oolngformat, maxch) + default: + switch (olngunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oolngformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oolngformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oolngformat, maxch) + } + } + } + } else + call strcpy (olngformat, oolngformat, maxch) + + if (olatformat[1] == EOS) { + if (sk_stati (cooin, S_STATUS) == ERR) + call strcpy ("%10.3f", oolatformat, maxch) + else { + if (sk_stati(cooout, S_STATUS) == ERR) + sptype = sk_stati (cooin, S_PIXTYPE) + else + sptype = sk_stati (cooout, S_PIXTYPE) + switch (sptype) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + call strcpy ("%10.3f", oolatformat, maxch) + default: + switch (olatunits) { + case SKY_HOURS: + call strcpy ("%12.3h", oolatformat, maxch) + case SKY_DEGREES: + call strcpy ("%12.2h", oolatformat, maxch) + case SKY_RADIANS: + call strcpy ("%13.7g", oolatformat, maxch) + } + } + } + } else + call strcpy (olatformat, oolatformat, maxch) +end + + +# SK_ICTRAN -- Compile the input mwcs transformation. + +pointer procedure sk_ictran (cooin, mwin) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor + +int axbits +pointer ctin +int sk_stati() +pointer mw_sctran() +errchk mw_sctran() + +begin + if (mwin != NULL) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + axbits = 2 ** (sk_stati(cooin, S_XLAX) - 1) + + 2 ** (sk_stati(cooin, S_YLAX) - 1) + iferr { + if (sk_stati(cooin, S_PIXTYPE) == PIXTYPE_PHYSICAL) + ctin = mw_sctran (mwin, "physical", "world", axbits) + else + ctin = mw_sctran (mwin, "logical", "world", axbits) + } then + call error (0, "Error compiling input mwcs transform") + default: + ctin = NULL + } + } else { + ctin = NULL + } + + return (ctin) +end + + +# SK_IUNITS -- Set the input celestial coordinate units. + +procedure sk_iunits (cooin, mwin, ilngunits, ilatunits, oilngunits, oilatunits) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int oilngunits #O the output input ra/longitude units +int oilatunits #O the output input dec/latitude units + +int sk_stati() + +begin + if (mwin != NULL) { + switch (sk_stati(cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + oilngunits = SKY_DEGREES + oilatunits = SKY_DEGREES + default: + oilngunits = ilngunits + oilatunits = ilatunits + } + } else { + oilngunits = ilngunits + oilatunits = ilatunits + } +end + + +# SK_OCTRAN -- Compile the output mwcs transformation. + +pointer procedure sk_octran (cooout, mwout) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor + +int axbits +pointer ctout +int sk_stati() +pointer mw_sctran() +errchk mw_sctran() + +begin + if (mwout != NULL) { + switch (sk_stati(cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + axbits = 2 ** (sk_stati (cooout, S_XLAX) - 1) + + 2 ** (sk_stati (cooout, S_YLAX) - 1) + iferr { + if (sk_stati (cooout, S_PIXTYPE) == PIXTYPE_PHYSICAL) + ctout = mw_sctran (mwout, "world", "physical", axbits) + else + ctout = mw_sctran (mwout, "world", "logical", axbits) + } then + call error (0, "Error compiling output mwcs transform") + default: + ctout = NULL + } + } else { + ctout = NULL + } + + return (ctout) +end + + +# SK_OUNITS -- Compile the output mwcs transformation and set the output +# celestial coordinate units. + +procedure sk_ounits (cooout, mwout, olngunits, olatunits, oolngunits, + oolatunits) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +int oolngunits #O the output output ra/longitude units +int oolatunits #O the output output dec/latitude units + +int sk_stati() + +begin + if (mwout != NULL) { + switch (sk_stati(cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_TV, PIXTYPE_PHYSICAL: + oolngunits = SKY_RADIANS + oolatunits = SKY_RADIANS + default: + oolngunits = olngunits + oolatunits = olatunits + } + } else { + oolngunits = olngunits + oolatunits = olatunits + } +end + + +# SK_INCC -- Transform the input coordinates to the correct celestial +# coordinates in radians. + +procedure sk_incc (cooin, mwin, ctin, ilngunits, ilatunits, ilng, ilat, + olng, olat) + +pointer cooin #I the input coordinate descriptor +pointer mwin #I the input mwcs descriptor +pointer ctin #I the mwcs transformation descriptor +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +double ilng #I the input ra/longitude coordinates +double ilat #I the input dec/latitude coordinates +double olng #O the output ra/longitude coordinates +double olat #O the output dec/latitude coordinates + +double tlng, tlat +double sk_statd() +int sk_stati() + +begin + # Convert the input image coordinates to world coordinates. + if (mwin != NULL) { + switch (sk_stati (cooin, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_PHYSICAL: + if (ctin == NULL) { + olng = ilng + olat = ilat + } else if (sk_stati (cooin, S_PLNGAX) < sk_stati (cooin, + S_PLATAX)) { + call mw_c2trand (ctin, ilng, ilat, olng, olat) + } else { + call mw_c2trand (ctin, ilng, ilat, olat, olng) + } + case PIXTYPE_TV: + tlng = (ilng - sk_statd(cooin, S_VXOFF)) / + sk_statd (cooin, S_VXSTEP) + tlat = (ilat - sk_statd (cooin, S_VYOFF)) / + sk_statd (cooin, S_VYSTEP) + if (ctin == NULL) { + olng = tlng + olat = tlat + } else if (sk_stati (cooin, S_PLNGAX) < sk_stati (cooin, + S_PLATAX)) { + call mw_c2trand (ctin, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctin, tlng, tlat, olat, olng) + } + case PIXTYPE_WORLD: + olng = ilng + olat = ilat + } + } else { + olng = ilng + olat = ilat + } + + # Convert the input values to radians. + switch (ilngunits) { + case SKY_HOURS: + olng = DEGTORAD(15.0d0 * olng) + case SKY_DEGREES: + olng = DEGTORAD(olng) + case SKY_RADIANS: + ; + } + switch (ilatunits) { + case SKY_HOURS: + olat = DEGTORAD(15.0d0 * olat) + case SKY_DEGREES: + olat = DEGTORAD(olat) + case SKY_RADIANS: + ; + } +end + + +# SK_OUTCC -- Transform the output celestial coordinates to the correct +# output coordinate system. + +procedure sk_outcc (cooout, mwout, ctout, olngunits, olatunits, ilng, ilat, + olng, olat) + +pointer cooout #I the output coordinate descriptor +pointer mwout #I the output mwcs descriptor +pointer ctout #I the output mwcs transformation descriptor +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +double ilng #I the output ra/longitude coordinates +double ilat #I the output dec/latitude coordinates +double olng #O the output coordinates +double olat #O the output coordinates + +double tlng, tlat +double sk_statd() +int sk_stati() + +begin + # Convert the output image coordinates to image coordinates. + #if (mwout == NULL || (sk_stati(cooin, S_PIXTYPE) == PIXTYPE_WORLD && + # sk_stati (cooout, S_PIXTYPE) == PIXTYPE_WORLD)) { + if (mwout == NULL || ctout == NULL) { + switch (olngunits) { + case SKY_HOURS: + olng = RADTODEG(ilng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(ilng) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olat = RADTODEG(ilat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(ilat) + case SKY_RADIANS: + ; + } + } else { + switch (sk_stati (cooout, S_PIXTYPE)) { + case PIXTYPE_LOGICAL, PIXTYPE_PHYSICAL: + tlng = RADTODEG(ilng) + tlat = RADTODEG(ilat) + if (ctout == NULL) { + olng = tlat + olat = tlng + } else if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, + S_PLATAX)) { + call mw_c2trand (ctout, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctout, tlat, tlng, olng, olat) + } + case PIXTYPE_TV: + tlng = RADTODEG(ilng) + tlat = RADTODEG(ilat) + if (ctout == NULL) { + olng = tlat + olat = tlng + } else if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, + S_PLATAX)) { + call mw_c2trand (ctout, tlng, tlat, olng, olat) + } else { + call mw_c2trand (ctout, tlat, tlng, olng, olat) + } + olng = olng * sk_statd(cooout, S_VXSTEP) + + sk_statd(cooout, S_VXOFF) + olat = olat * sk_statd (cooout, S_VYSTEP) + + sk_statd (cooout, S_VYOFF) + case PIXTYPE_WORLD: + if (sk_stati(cooout, S_PLNGAX) > sk_stati(cooout, + S_PLATAX)) { + olng = ilat + olat = ilng + switch (olngunits) { + case SKY_HOURS: + olat = RADTODEG(olat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(olat) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olng = RADTODEG(olng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(olng) + case SKY_RADIANS: + ; + } + } else { + switch (olngunits) { + case SKY_HOURS: + olng = RADTODEG(ilng / 15.0d0) + case SKY_DEGREES: + olng = RADTODEG(ilng) + case SKY_RADIANS: + ; + } + switch (olatunits) { + case SKY_HOURS: + olat = RADTODEG(ilat / 15.0d0) + case SKY_DEGREES: + olat = RADTODEG(ilat) + case SKY_RADIANS: + ; + } + } + } + } +end diff --git a/pkg/images/imcoords/src/skycur.key b/pkg/images/imcoords/src/skycur.key new file mode 100644 index 00000000..2aa61fe1 --- /dev/null +++ b/pkg/images/imcoords/src/skycur.key @@ -0,0 +1,38 @@ + INTERACTIVE KEYSTROKE COMMANDS + +? Print help +: Execute colon command +spbar Measure object +q Exit task + + + COLON COMMANDS + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT COORDINATE SYSTEMS + +image [tv] + + VALID OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID OUTPUT CELESTIAL COORDINATE UNITS AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7g diff --git a/pkg/images/imcoords/src/starfind.h b/pkg/images/imcoords/src/starfind.h new file mode 100644 index 00000000..d535716a --- /dev/null +++ b/pkg/images/imcoords/src/starfind.h @@ -0,0 +1,51 @@ +# STARFIND Structure + +define LEN_STARFIND (15) + +define SF_HWHMPSF Memr[P2R($1)] # HWHM of the PSF in pixels +define SF_FRADIUS Memr[P2R($1+1)] # Fitting radius in HWHM +define SF_DATAMIN Memr[P2R($1+2)] # Minimum good data limit in ADU +define SF_DATAMAX Memr[P2R($1+3)] # Maximum good data limit in ADU +define SF_THRESHOLD Memr[P2R($1+4)] # Detection threshold in ADU +define SF_SEPMIN Memr[P2R($1+5)] # Minimum separation in HWHM +define SF_SHARPLO Memr[P2R($1+6)] # Lower sharpness limit +define SF_SHARPHI Memr[P2R($1+7)] # Upper sharpness limit +define SF_ROUNDLO Memr[P2R($1+8)] # Lower roundness limit +define SF_ROUNDHI Memr[P2R($1+9)] # Upper roundness limit +define SF_MAGLO Memr[P2R($1+10)] # Lower magnitude limit +define SF_MAGHI Memr[P2R($1+11)] # Upper magnitude limit +define SF_NPIXMIN Memi[$1+12] # Minimum pixels above threshold + + +# default values + +define DEF_HWHMPSF 1.0 +define DEF_FRADIUS 1.5 +define DEF_THRESHOLD 0.0 +define DEF_SEPMIN 1.5 +define DEF_DATAMIN -MAX_REAL +define DEF_DATAMAX MAX_REAL +define DEF_SHARPLO 0.2 +define DEF_SHARPHI 1.0 +define DEF_ROUNDLO -1.0 +define DEF_ROUNDHI 1.0 +define DEF_MAGLO -MAX_REAL +define DEF_MAGHI MAX_REAL +define DEF_NPIXMIN 5 + + +# define the gaussian sums structure + +define LEN_GAUSS 10 + +define GAUSS_SUMG 1 +define GAUSS_SUMGSQ 2 +define GAUSS_PIXELS 3 +define GAUSS_DENOM 4 +define GAUSS_SGOP 5 + + +# miscellaneous constants + +define HWHM_TO_SIGMA 0.8493218 +define RMIN 2.001 diff --git a/pkg/images/imcoords/src/t_ccfind.x b/pkg/images/imcoords/src/t_ccfind.x new file mode 100644 index 00000000..0a8bc9b8 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccfind.x @@ -0,0 +1,782 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# T_CCFIND -- Locate objects with known celestial coordinates in an image +# using the image WCS or a user supplied WCS. Write the matched celestial and +# coordinates list to the output file. + +procedure t_ccfind () + +bool usewcs, center, verbose +double xref, yref, xmag, ymag, xrot, yrot, tlngref, tlatref, txref, tyref +double txmag, tymag, txrot, tyrot +int ip, nchars, sbox, cbox, min_sigdigits, ncenter, maxiter, tol +int inlist, ninfiles, outlist, noutfiles, imlist, nimages, in, out +int lngcolumn, latcolumn, lngunits, latunits, coostat, refstat +int lngrefunits, latrefunits, proj, pfd +pointer sp, insystem, refsystem, infile, outfile, image, projstr, str +pointer slngref, slatref, xformat, yformat, coo, refcoo, im, mw +real datamin, datamax, back + +bool clgetb() +double clgetd(), imgetd() +int clpopnu(), clplen(), imtopenp(), imtlen(), clgeti(), clgwrd(), strlen() +int sk_decwcs(), sk_decim(), open(), clgfil(), imtgetim(), strncmp(), ctod() +int cc_listran(), strdic(), cc_rdproj() +real clgetr() +pointer immap(), cc_mkwcs() +errchk imgstr(), imgetd(), open() + +begin + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (refsystem, SZ_FNAME, TY_CHAR) + call salloc (slngref, SZ_FNAME, TY_CHAR) + call salloc (slatref, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input data file list. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input coordinate file list is empty\n") + call clpcls (inlist) + call sfree (sp) + return + } + + # Get the output results lists. + outlist = clpopnu ("output") + noutfiles = clplen (outlist) + if (noutfiles != ninfiles) { + call eprintf ( + "Error: The number of input and output files must be the same\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + + # Get the input image list. + imlist = imtopenp ("images") + nimages = imtlen (imlist) + if (nimages != ninfiles) { + call eprintf ( + "Error: The number of input files and images must be the same\n") + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Get the coordinates file format. + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the user wcs if there is one. + usewcs = clgetb ("usewcs") + if (! usewcs) { + xref = clgetd ("xref") + yref = clgetd ("yref") + xmag = clgetd ("xmag") + ymag = clgetd ("ymag") + xrot = clgetd ("xrot") + yrot = clgetd ("yrot") + call clgstr ("lngref", Memc[slngref], SZ_FNAME) + call clgstr ("latref", Memc[slatref], SZ_FNAME) + call clgstr ("refsystem", Memc[refsystem], SZ_FNAME) + if (strncmp (Memc[refsystem], "INDEF", 5) == 0) + Memc[refsystem] = EOS + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + } + iferr (lngrefunits = clgwrd ("lngrefunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngrefunits = 0 + iferr (latrefunits = clgwrd ("latrefunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latrefunits = 0 + + # Get the centering parameters. + center = clgetb ("center") + sbox = clgeti ("sbox") + cbox = clgeti ("cbox") + datamin = clgetr ("datamin") + datamax = clgetr ("datamax") + back = clgetr ("background") + maxiter = clgeti ("maxiter") + tol = clgeti ("tolerance") + if (mod (sbox,2) == 0) + sbox = sbox + 1 + if (mod (cbox,2) == 0) + cbox = cbox + 1 + + # Get the output formatting parameters. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + #min_sigdigits = clgeti ("min_sigdigits") + min_sigdigits = 7 + verbose = clgetb ("verbose") + + # Open the input coordinate system and determine its units. + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Loop over the files. + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF && + clgfil (outlist, Memc[outfile], SZ_FNAME) != EOF && + imtgetim(imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input file of celestial coordinates. + in = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the output file of matched coordinates. + out = open (Memc[outfile], NEW_FILE, TEXT_FILE) + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) != 2) { + call printf ("Skipping file: %s Image: %s is not 2D\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call imunmap (im) + call close (in) + call close (out) + next + } + + # Print the input and out file information. + if (verbose && out != STDOUT) { + call printf ("\nInput File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + call printf (" Image: %s Wcs: %s\n") + call pargstr (Memc[image]) + call pargstr ("") + } + call fprintf (out, "\n# Input File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + call fprintf (out, "# Image: %s Wcs: %s\n") + call pargstr (Memc[image]) + call pargstr ("") + + # Open the wcs and compile the transformation. + if (usewcs) { + + # Read the image wcs, skipping to the next image if the wcs + # is unreadable. + refstat = sk_decim (im, Memc[image], mw, refcoo) + if (refstat == ERR || mw == NULL) { + if (verbose && out != STDOUT) + call printf ( + "Error: Cannot decode the image coordinate system\n") + call fprintf (out, + "Error: Cannot decode the image coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call sk_close (refcoo) + call imunmap (im) + call close (out) + call close (in) + next + } + + } else { + + # Get the image pixel reference coordinates + if (IS_INDEFD(xref)) + txref = (1.0d0 + IM_LEN(im,1)) / 2.0 + else + txref = xref + if (IS_INDEFD(yref)) + tyref = (1.0d0 + IM_LEN(im,2)) / 2.0 + else + tyref = yref + + # Get the image scale in arcsec / pixel. + if (IS_INDEFD(xmag)) + txmag = 1.0d0 + else + txmag = xmag + if (IS_INDEFD(ymag)) + tymag = 1.0d0 + else + tymag = ymag + + # Get the coordinate axes rotation angles in degrees. + if (IS_INDEFD(xrot)) + txrot = 0.0d0 + else + txrot = xrot + if (IS_INDEFD(yrot)) + tyrot = 0.0d0 + else + tyrot = yrot + + # Get the celestial coordinates of the tangent point from + # the image header or from the user. + iferr (tlngref = imgetd (im, Memc[slngref])) { + ip = 1 + nchars = ctod (Memc[slngref], ip, tlngref) + if (nchars <= 0 || nchars != strlen (Memc[slngref])) + tlngref = 0.0d0 + else if (IS_INDEFD(tlngref) || tlngref < 0.0d0 || + tlngref > 360.0d0) + tlngref = 0.0d0 + } + iferr (tlatref = imgetd (im, Memc[slatref])) { + ip = 1 + nchars = ctod (Memc[slatref], ip, tlatref) + if (nchars <= 0 || nchars != strlen (Memc[slatref])) + tlatref = 0.0d0 + else if (IS_INDEFD(tlatref) || tlatref < -90.0d0 || + tlatref > 90.0d0) + tlatref = 0.0d0 + } + + # Get the image reference system from the image header + # or from the user. + if (Memc[refsystem] == EOS) + call strcpy (Memc[refsystem], Memc[str], SZ_FNAME) + else { + iferr (call imgstr (im, Memc[refsystem], Memc[str], + SZ_FNAME)) + call strcpy (Memc[refsystem], Memc[str], SZ_FNAME) + } + refstat = sk_decwcs (Memc[str], mw, refcoo, NULL) + if (refstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + call sk_close (refcoo) + refstat = sk_decwcs (Memc[insystem], mw, refcoo, NULL) + } + + # Force the units of the tangent point. + if (lngrefunits > 0) + call sk_seti (refcoo, S_NLNGUNITS, lngrefunits) + if (latrefunits > 0) + call sk_seti (refcoo, S_NLATUNITS, latrefunits) + + # Build the wcs. + mw = cc_mkwcs (refcoo, Memc[projstr], tlngref, tlatref, + txref, tyref, txmag, tymag, txrot, tyrot, false) + + # Force the wcs to look like an image wcs. + call sk_seti (refcoo, S_PIXTYPE, PIXTYPE_LOGICAL) + + } + + # Print out a description of the input coordinate and image + # systems. + if (verbose && out != STDOUT) + call sk_iiprint ("Insystem", Memc[insystem], NULL, coo) + call sk_iiwrite (out, "Insystem", Memc[insystem], NULL, coo) + call sk_stats (refcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (usewcs) { + if (verbose && out != STDOUT) { + call sk_iiprint ("Refsystem", Memc[str], mw, refcoo) + } + call sk_iiwrite (out, "Refsystem", Memc[str], mw, refcoo) + call fprintf (out, "\n") + } else { + if (verbose && out != STDOUT) { + call sk_iiprint ("Refsystem", Memc[str], NULL, refcoo) + } + call sk_iiwrite (out, "Refsystem", Memc[str], NULL, refcoo) + call fprintf (out, "\n") + } + + # Transform the coordinate lists. + ncenter = cc_listran (in, out, im, NULL, mw, coo, refcoo, lngcolumn, + latcolumn, lngunits, latunits, lngrefunits, latrefunits, + center, sbox / 2, cbox / 2, datamin, datamax, back, + maxiter, tol, Memc[xformat], Memc[yformat], min_sigdigits) + + if (verbose && out != STDOUT) { + call printf ("Located %d objects in image %s\n") + call pargi (ncenter) + call pargstr (Memc[image]) + call printf ("\n") + } + call sk_close (refcoo) + call mw_close (mw) + call imunmap (im) + call close (out) + call close (in) + } + + + call sk_close (coo) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) +end + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# CC_LISTRAN -- Transform the coordinate list. + +int procedure cc_listran (infd, outfd, im, mwin, mwout, cooin, cooout, + lngcolumn, latcolumn, ilngunits, ilatunits, olngunits, olatunits, + center, sbox, cbox, datamin, datamax, back, maxiter, tol, oxformat, + oyformat, min_sigdigits) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +pointer im #I the input image descriptor +pointer mwin #I the input image wcs +pointer mwout #I the output image wcs +pointer cooin #I the input coordinate descriptor +pointer cooout #I the output coordinate descriptor +int lngcolumn #I the input ra/longitude column +int latcolumn #I the input dec/latitude column +int ilngunits #I the input ra/longitude units +int ilatunits #I the input dec/latitude units +int olngunits #I the output ra/longitude units +int olatunits #I the output dec/latitude units +bool center #I center the pixel coordinates +int sbox #I the search box half-width in pixels +int cbox #I the centering box half-width in pixels +real datamin #I the minimum good data value +real datamax #I the maximum good data value +real back #I the background reference value +int maxiter #I the maximum number of iterations +int tol #I the fitting tolerance in pixels +char oxformat[ARB] #I the output x format +char oyformat[ARB] #I the output y format +int min_sigdigits #I the minimum number of significant digits + +double ilng, ilat, tlng, tlat, olng, olat +int nline, ip, max_fields, nfields, offset, nchars, nsdig_lng, nsdig_lat +int tilngunits, tilatunits, tolngunits, tolatunits, cier, ncenter +pointer sp, inbuf, linebuf, field_pos, outbuf, ctin, ctout +pointer toxformat, toyformat +int sk_stati(), li_get_numd(), getline(), cc_center() +pointer sk_ictran(), sk_octran() +errchk sk_ictran(), sk_octran() + +begin + # Compile the input and output transformations. + iferr { + ctin = sk_ictran (cooin, mwin) + ctout = sk_octran (cooout, mwout) + } then + return + + # Allocate some memory. + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (toxformat, SZ_FNAME, TY_CHAR) + call salloc (toyformat, SZ_FNAME, TY_CHAR) + + # Set the default input and output units. + if (ilngunits <= 0) + tilngunits = sk_stati (cooin, S_NLNGUNITS) + else + tilngunits = ilngunits + if (ilatunits <= 0) + tilatunits = sk_stati (cooin, S_NLATUNITS) + else + tilatunits = ilatunits + if (olngunits <= 0) + tolngunits = sk_stati (cooout, S_NLNGUNITS) + else + tolngunits = olngunits + if (olatunits <= 0) + tolatunits = sk_stati (cooout, S_NLATUNITS) + else + tolatunits = olatunits + + # Set the output format. + call sk_oformats (cooin, cooout, oxformat, oyformat, + tolngunits, tolatunits, Memc[toxformat], Memc[toyformat], + SZ_FNAME) + + # Check the input and output units. + call sk_iunits (cooin, mwin, tilngunits, tilatunits, tilngunits, + tilatunits) + call sk_ounits (cooout, mwout, tolngunits, tolatunits, tolngunits, + tolatunits) + + # Loop over the input coordinates. + max_fields = MAX_FIELDS + ncenter = 0 + for (nline = 1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Check for blank lines and comment lines. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + if (lngcolumn > nfields || latcolumn > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: too few fields\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+lngcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilng, nsdig_lng) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: bad ra value\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+latcolumn-1] + nchars = li_get_numd (Memc[linebuf+offset-1], ilat, nsdig_lat) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: bad dec value\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + #call putline (outfd, Memc[linebuf]) + next + } + + # Convert the input coordinates to world coordinates in radians. + call sk_incc (cooin, mwin, ctin, tilngunits, tilatunits, ilng, + ilat, olng, olat) + + # Perform the transformation. + call sk_lltran (cooin, cooout, olng, olat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tlng, tlat) + + # Convert the output celestial coordinates from radians to output + # coordinates. + call sk_outcc (cooout, mwout, ctout, tolngunits, tolatunits, + tlng, tlat, olng, olat) + + # Is the object on the image ? + if (olng < 0.5d0 || olng > (IM_LEN(im,1) + 0.5d0) || + olat < 0.5d0 || olat > (IM_LEN(im,2) + 0.5d0)) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Skipping object %d in file %s: off image %s\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + call pargstr (IM_HDRFILE(im)) + #call putline (outfd, Memc[linebuf]) + next + } + + # Center the coordinates. + if (center) { + cier = cc_center (im, sbox, cbox, datamin, datamax, back, + maxiter, tol, olng, olat, olng, olat) + if (cier == ERR) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ( + "Skipping object %d in file %s: cannot center in image %s\n") + call pargi (nline) + call pargstr (Memc[outbuf]) + call pargstr (IM_HDRFILE(im)) + #call putline (outfd, Memc[linebuf]) + next + } + } + + # Output the results. + call li_append_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + olng, olat, Memc[toxformat], Memc[toyformat], nsdig_lng, + nsdig_lat, min_sigdigits) + call putline (outfd, Memc[outbuf]) + ncenter = ncenter + 1 + } + + call sfree (sp) + + return (ncenter) +end + + +# CC_CENTER -- Given an initial x and y coordinate compute a more accurate +# center using a centroiding technique. + +int procedure cc_center (im, sbox, cbox, datamin, datamax, back, maxiter, + tolerance, xinit, yinit, xcenter, ycenter) + +pointer im #I pointer to the input image +int sbox #I the search box half-width in pixels +int cbox #I the centering box half-width in pixels +real datamin #I the minimum good data value +real datamax #I the maximum good data value +real back #I the background reference value +int maxiter #I the maximum number of iterations. +int tolerance #I the tolerance for convergence in pixels +double xinit, yinit #I the initial x and y positions +double xcenter, ycenter #I the final x and y positions + +bool converged +double xold, yold, xnew, ynew +int i, fbox, x1, x2, y1, y2, nx, ny +real lo, hi, sky +pointer buf, sp, xbuf, ybuf +pointer imgs2r() +real cc_ctr1d() +errchk imgs2r(), cc_threshold(), cc_rowsum(), cc_colsum(), cc_ctr1d() + + +begin + xold = xinit + yold = yinit + converged = false + + do i = 1, maxiter { + + if (i == 1) + fbox = sbox + else + fbox = cbox + x1 = max (nint (xold) - fbox, 1) + x2 = min (nint (xold) + fbox, IM_LEN(im,1)) + y1 = max (nint (yold) - fbox, 1) + y2 = min (nint (yold) + fbox, IM_LEN(im,2)) + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + call smark (sp) + call salloc (xbuf, nx, TY_REAL) + call salloc (ybuf, ny, TY_REAL) + + iferr { + buf = imgs2r (im, x1, x2, y1, y2) + call cc_threshold (Memr[buf], nx * ny, datamin, datamax, + back, lo, hi, sky) + call cc_rowsum (Memr[buf], Memr[xbuf], nx, ny, lo, hi, sky) + call cc_colsum (Memr[buf], Memr[ybuf], nx, ny, lo, hi, sky) + xnew = x1 + cc_ctr1d (Memr[xbuf], nx) + ynew = y1 + cc_ctr1d (Memr[ybuf], ny) + } then { + call sfree (sp) + return (ERR) + } + + call sfree (sp) + + # Force at least one iteration. + if (i > 1) { + if (abs(nint(xnew) - nint(xold)) <= tolerance && + abs(nint(ynew) - nint(yold)) <= tolerance) { + converged = true + break + } + } + + xold = xnew + yold = ynew + } + + if (converged) { + xcenter = xnew + ycenter = ynew + return (OK) + } else { + xcenter = xinit + ycenter = yinit + return (ERR) + } +end + + +# CC_THRESHOLD -- Find the low and high thresholds for the subraster. + +procedure cc_threshold (raster, npix, datamin, datamax, back, ldatamin, + ldatamax, lback) + +real raster[ARB] #I input data +int npix #I length of input data +real datamin #I minimum good data value +real datamax #I maximum good data value +real back #I background value +real ldatamin #I local minimum good data value +real ldatamax #I local maximum good data value +real lback #I local background value + +real junk +int awvgr() +errchk alimr, awvgr + +begin + # use the local data min or max for thresholds that are INDEF. + if (IS_INDEFR(datamin) || IS_INDEFR(datamax)) + call alimr (raster, npix, ldatamin, ldatamax) + if (! IS_INDEFR(datamin)) + ldatamin = datamin + if (! IS_INDEFR(datamax)) + ldatamax = datamax + + if (IS_INDEFR(back)) { + if (awvgr (raster, npix, lback, junk, ldatamin, + ldatamax) <= 0) + call error (1, "No data in good data range") + } else + lback = back + + ldatamin = max (ldatamin, lback) + ldatamax = ldatamax +end + + +# CC_ROWSUM -- Sum all rows in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure cc_rowsum (raster, row, nx, ny, lo, hi, back) + +real raster[nx,ny] #I the input 2-D subraster +real row[ARB] #O the output averaged row vector +int nx, ny #I dimensions of the subraster +real lo, hi #I minimum and maximum good data values +real back #I the background value + +int i, j +real pix, minpix, maxpix + +begin + # Compute the x marginal. + call aclrr (row, nx) + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + row[i] = row[i] + pix - back + } + call adivkr (row, real(ny), row, nx) + + # Check for low values. + call alimr (row, nx, minpix, maxpix) + if (minpix < 0.0) + call error (1, "Negative value in marginal row") +end + + +# CC_COLSUM -- Sum all columns in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure cc_colsum (raster, col, nx, ny, lo, hi, back) + +real raster[nx,ny] #I 2-D subraster +real col[ARB] #O 1-D squashed col vector +int nx, ny #I dimensions of the subraster +real lo, hi #I minimum and maximum good data values +real back #I the background value + + +int i, j +real pix, minpix, maxpix + +begin + # Compute the y marginal. + call aclrr (col, ny) + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + col[j] = col[j] + pix - back + } + call adivkr (col, real(nx), col, ny) + + # Check for low values. + call alimr (col, ny, minpix, maxpix) + if (minpix < 0.) + call error (1, "Negative value in marginal column") +end + + +# CC_CNTR1D -- Compute the the first moment. + +real procedure cc_ctr1d (a, npix) + +real a[ARB] #I marginal vector +int npix #I size of the vector + +real centroid, pix, sumi, sumix +int i + +begin + sumi = 0. + sumix = 0. + do i = 1, npix { + pix = a[i] + sumi = sumi + pix + sumix = sumix + pix * (i-1) + } + + if (sumi == 0.0) + call error (1, "The center is undefined\n") + else + centroid = sumix / sumi + + return (centroid) +end + diff --git a/pkg/images/imcoords/src/t_ccget.x b/pkg/images/imcoords/src/t_ccget.x new file mode 100644 index 00000000..8955daf9 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccget.x @@ -0,0 +1,1201 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include + +# Define the input data structure + +define DC_DLENGTH 10 +define DC_NCOLUMNS Memi[$1] # the number of columns in record +define DC_LNGCOLUMN Memi[$1+1] # the ra / longitude column index +define DC_LATCOLUMN Memi[$1+2] # the dec / latitude column index +define DC_COLNAMES Memi[$1+3] # the column names pointer +define DC_RECORD Memi[$1+4] # the record pointer +define DC_COFFSETS Memi[$1+5] # the column offsets + +define MAX_NCOLUMNS 100 # the maximum number of columns +define SZ_COLNAME 19 # the column name +define TABSIZE 8 # the spacing of the tab stops + +# Define the output structure + +define EC_ELENGTH 10 + +define EC_NEXPR Memi[$1] # the number of expressions +define EC_ELIST Memi[$1+1] # the expression list pointer +define EC_ERANGES Memi[$1+2] # the expression column ranges +define EC_EFORMATS Memi[$1+3] # the expression formats +define EC_ELNGFORMAT Memi[$1+4] # the expression formats +define EC_ELATFORMAT Memi[$1+5] # the expression formats + +define MAX_NEXPR 20 +define MAX_NERANGES 100 +define SZ_EXPR SZ_LINE +define SZ_EFORMATS 9 + +# T_CCGET -- Given a field center, field width, and field epoch extract objects +# within the rectangular field from a catalog. + +procedure t_ccget () + +double dlngcenter, dlatcenter, dlngwidth, dlatwidth, tlngcenter, tlatcenter +double dlng1, dlng2, dlat1, dlat2 +int ip, inlist, ninfiles, outlist, noutfiles, fclngunits, fclatunits +int fldstat, catstat, outstat, catlngunits, catlatunits, olngunits +int olatunits, in, out +pointer sp, lngcenter, latcenter, fcsystem, catsystem, outsystem, olngformat +pointer olatformat, lngcolumn, latcolumn, colnames, exprs, formats +pointer infile, outfile, str +pointer fldcoo, catcoo, outcoo, mw, dc, ec +bool verbose +double clgetd() +pointer cc_dinit(), cc_einit() +int clpopnu(), clplen(), ctod(), strncmp(), clgwrd(), sk_decwcs() +int sk_stati(), clgfil(), open() +bool clgetb(), streq() +errchk clgwrd() + +begin + # Open the list of input catalogs. These catalogs must have the + # same format. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input catalog list is empty\n") + call clpcls (inlist) + return + } + + # Open the list of output catalogs. The number of output catalogs + # must be 1 or equal to the number of input catalogs. + outlist = clpopnu ("output") + noutfiles = clplen (outlist) + if (noutfiles <= 0) { + call eprintf ("Error: The output catalog list is empty\n") + call clpcls (inlist) + call clpcls (outlist) + return + } else if (noutfiles > 1 && noutfiles != ninfiles) { + call eprintf ( + "Error: The number of input and output catalogs are not the same\n") + call clpcls (inlist) + call clpcls (outlist) + return + } + + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (lngcenter, SZ_FNAME, TY_CHAR) + call salloc (latcenter, SZ_FNAME, TY_CHAR) + call salloc (fcsystem, SZ_FNAME, TY_CHAR) + call salloc (catsystem, SZ_FNAME, TY_CHAR) + call salloc (lngcolumn, SZ_FNAME, TY_CHAR) + call salloc (latcolumn, SZ_FNAME, TY_CHAR) + call salloc (colnames, SZ_LINE, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (olngformat, SZ_FNAME, TY_CHAR) + call salloc (olatformat, SZ_FNAME, TY_CHAR) + call salloc (exprs, SZ_LINE, TY_CHAR) + call salloc (formats, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the field center coordinates and make some preliminary checks. + call clgstr ("lngcenter", Memc[lngcenter], SZ_FNAME) + call clgstr ("latcenter", Memc[latcenter], SZ_FNAME) + ip = 1 + if (ctod (Memc[lngcenter], ip, dlngcenter) <= 0) + dlngcenter = INDEFD + else if (dlngcenter < 0.0 || dlngcenter > 360.0) + dlngcenter = INDEFD + ip = 1 + if (ctod (Memc[latcenter], ip, dlatcenter) <= 0) + dlatcenter = INDEFD + else if (dlatcenter < -90.0 || dlatcenter > 90.0) + dlatcenter = INDEFD + if (IS_INDEFD(dlngcenter) || IS_INDEFD(dlatcenter)) { + call eprintf ( "Error: Undefined field center\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + dlngwidth = clgetd ("lngwidth") + if (dlngwidth < 0.0 || dlngwidth > 360.0) + dlngwidth = INDEFD + dlatwidth = clgetd ("latwidth") + if (dlatwidth < 0.0 || dlatwidth > 180.0) + dlatwidth = INDEFD + if (IS_INDEFD(dlngwidth) || IS_INDEFD(dlatwidth)) { + call eprintf ( "Error: Undefined field width\n") + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Get the field coordinate system and convert INDEF to EOS + # to avoid passing the wcs decoding routine a large number. + call clgstr ("fcsystem", Memc[fcsystem], SZ_FNAME) + if (strncmp (Memc[fcsystem], "INDEF", 5) == 0) + Memc[fcsystem] = EOS + + # Get the field center coordinate units. + iferr (fclngunits = clgwrd ("fclngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + fclngunits = 0 + iferr (fclatunits = clgwrd ("fclatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + fclatunits = 0 + + # Get the coordinates file format. + call clgstr ("lngcolumn", Memc[lngcolumn], SZ_FNAME) + call clgstr ("latcolumn", Memc[latcolumn], SZ_FNAME) + + # Get the catalog coordinate system and convert INDEF to EOS + # to avoid passing the wcs decoding routine a large number. + call clgstr ("catsystem", Memc[catsystem], SZ_FNAME) + if (strncmp (Memc[catsystem], "INDEF", 5) == 0) + Memc[catsystem] = EOS + + # Get the input catalog coordinate units. + iferr (catlngunits = clgwrd ("catlngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + catlngunits = 0 + iferr (catlatunits = clgwrd ("catlatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + catlatunits = 0 + + # Get the output catalog coordinates system. + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + if (strncmp (Memc[outsystem], "INDEF", 5) == 0) + Memc[outsystem] = EOS + + # Get the output catalog coordinate units. + iferr (olngunits = clgwrd ("olngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + olngunits = 0 + iferr (olatunits = clgwrd ("olatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + olatunits = 0 + call clgstr ("olngformat", Memc[olngformat], SZ_LINE) + call clgstr ("olatformat", Memc[olatformat], SZ_LINE) + + # Get the output catalog format. + call clgstr ("colaliases", Memc[colnames], SZ_LINE) + call clgstr ("exprs", Memc[exprs], SZ_LINE) + call clgstr ("formats", Memc[formats], SZ_LINE) + + verbose = clgetb ("verbose") + + # Open the reference coordinate system. + if (streq (Memc[catsystem], Memc[fcsystem]) && + (fclngunits == catlngunits) && + (fclatunits == catlatunits)) { + fldcoo = NULL + } else { + fldstat = sk_decwcs (Memc[fcsystem], mw, fldcoo, NULL) + if (fldstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + fldcoo = NULL + } + } + + # Open the catalog coordinate system. + catstat = sk_decwcs (Memc[catsystem], mw, catcoo, NULL) + if (catstat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + if (fldcoo != NULL) + call sk_close (fldcoo) + call clpcls (inlist) + call clpcls (outlist) + call sfree (sp) + return + } + + # Determine the units of the input coordinate system. + if (catlngunits <= 0) + catlngunits = sk_stati (catcoo, S_NLNGUNITS) + if (catlatunits <= 0) + catlatunits = sk_stati (catcoo, S_NLATUNITS) + call sk_seti (catcoo, S_NLNGUNITS, catlngunits) + call sk_seti (catcoo, S_NLATUNITS, catlatunits) + if (fldcoo == NULL) { + if (fclngunits <= 0) + fclngunits = sk_stati (catcoo, S_NLNGUNITS) + if (fclatunits <= 0) + fclatunits = sk_stati (catcoo, S_NLATUNITS) + } else { + if (fclngunits <= 0) + fclngunits = sk_stati (fldcoo, S_NLNGUNITS) + if (fclatunits <= 0) + fclatunits = sk_stati (fldcoo, S_NLATUNITS) + call sk_seti (fldcoo, S_NLNGUNITS, fclngunits) + call sk_seti (fldcoo, S_NLATUNITS, fclatunits) + } + + # Open the output catalog coordinate system. + if (streq (Memc[outsystem], Memc[catsystem]) && + (olngunits == catlngunits) && + (olatunits == catlatunits)) { + outcoo = NULL + } else { + outstat = sk_decwcs (Memc[outsystem], mw, outcoo, NULL) + if (outstat == ERR || mw != NULL) { + call eprintf ( + "Warning: Cannot decode the output coordinate system\n") + if (mw != NULL) + call mw_close (mw) + outcoo = NULL + } + } + + # Set the output catalog units. + if (outcoo == NULL) { + if (olngunits <= 0) + olngunits = sk_stati (catcoo, S_NLNGUNITS) + if (olatunits <= 0) + olatunits = sk_stati (catcoo, S_NLATUNITS) + } else { + if (olngunits <= 0) + olngunits = sk_stati (outcoo, S_NLNGUNITS) + if (olatunits <= 0) + olatunits = sk_stati (outcoo, S_NLATUNITS) + call sk_seti (outcoo, S_NLNGUNITS, olngunits) + call sk_seti (outcoo, S_NLATUNITS, olatunits) + } + + # Get default output coordinate formats. + if (outcoo != NULL) { + if (Memc[olngformat] == EOS || Memc[olngformat] == ' ') { + switch (sk_stati(outcoo, S_NLNGUNITS)) { + case SKY_HOURS: + call strcpy (" %010.1h", Memc[olngformat], SZ_EFORMATS) + case SKY_DEGREES: + call strcpy (" %9.0h", Memc[olngformat], SZ_EFORMATS) + case SKY_RADIANS: + call strcpy (" %9.7g", Memc[olngformat], SZ_EFORMATS) + } + } + if (Memc[olatformat] == EOS || Memc[olngformat] == ' ') { + switch (sk_stati(outcoo, S_NLATUNITS)) { + case SKY_HOURS: + call strcpy (" %010.1h", Memc[olatformat], SZ_EFORMATS) + case SKY_DEGREES: + call strcpy (" %9.0h", Memc[olatformat], SZ_EFORMATS) + case SKY_RADIANS: + call strcpy (" %9.7g", Memc[olatformat], SZ_EFORMATS) + } + } + } + + # Convert the field center coordinates to the catalog + # coordinate system. + if (fldcoo == NULL) { + tlngcenter = dlngcenter + tlatcenter = dlatcenter + } else { + call sk_ultran (fldcoo, catcoo, dlngcenter, dlatcenter, + tlngcenter, tlatcenter, 1) + } + + # Determine the corners of the field in degrees. At present + # the maximum longitude width is actually 180 not 360 degrees + # and the maximum latitude width is 180 degrees. + call cc_limits (catcoo, tlngcenter, tlatcenter, dlngwidth, + dlatwidth, dlng1, dlng2, dlat1, dlat2) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the data structure. + dc = cc_dinit (Memc[colnames], Memc[lngcolumn], Memc[latcolumn]) + + # Initialize the expressions structure. + ec = cc_einit (Memc[exprs], Memc[formats], Memc[olngformat], + Memc[olatformat]) + + # Decode the expressions using info in the data structure. + call cc_edecode (dc, ec) + + # Loop over the catalog files. + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the output file. + if (clgfil (outlist, Memc[outfile], SZ_FNAME) != EOF) + out = open (Memc[outfile], NEW_FILE, TEXT_FILE) + + # Print the input and output file information. + if (verbose && out != STDOUT) { + call printf ("\nCatalog File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + } + if (out != NULL) { + call fprintf (out, "\n# Catalog File: %s Output File: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[outfile]) + } + + # Print information about the field center coordinate system. + if (fldcoo == NULL) { + if (verbose && out != STDOUT) + call sk_iiprint ("Field System", Memc[catsystem], NULL, + catcoo) + if (out != NULL) + call sk_iiwrite (out, "Field System", Memc[catsystem], + NULL, catcoo) + } else { + if (verbose && out != STDOUT) + call sk_iiprint ("Field System", Memc[fcsystem], NULL, + fldcoo) + if (out != NULL) + call sk_iiwrite (out, "Field System", Memc[fcsystem], NULL, + fldcoo) + } + + # Print information about the input coordinate system. + if (verbose && out != STDOUT) + call sk_iiprint ( + "Catalog System", Memc[catsystem], NULL, catcoo) + if (out != NULL) + call sk_iiwrite (out, "Catalog System", Memc[catsystem], NULL, + catcoo) + + # Print information about the output coordinate system. + if (outcoo == NULL) { + if (verbose && out != STDOUT) + call sk_iiprint ("Output System", Memc[catsystem], NULL, + catcoo) + if (out != NULL) + call sk_iiwrite (out, "Output System", Memc[catsystem], + NULL, catcoo) + } else { + if (verbose && out != STDOUT) + call sk_iiprint ("Output System", Memc[outsystem], NULL, + outcoo) + if (out != NULL) + call sk_iiwrite (out, "Output System", Memc[outsystem], + NULL, outcoo) + } + + # Print the corners field parameters. + if (verbose && out != STDOUT) { + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call printf ( + "#\n# Field Center: %10h %9h Width: %0.4f %0.4f\n") + else + call printf ( + "#\n# Field Center: %11h %9h Width: %0.4f %0.4f\n") + call pargd (tlngcenter) + call pargd (tlatcenter) + call pargd (dlngwidth) + call pargd (dlatwidth) + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call printf ("# Field Limits: %9H %9H %9h %9h\n#\n") + else + call printf ("# Field Limits: %9h %9h %9h %9h\n#\n") + call pargd (dlng1) + call pargd (dlng2) + call pargd (dlat1) + call pargd (dlat2) + } + + if (out != NULL) { + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call fprintf (out, + "#\n# Field Center: %10h %9h Width: %0.4f %0.4f\n") + else + call fprintf (out, + "#\n# Field Center: %11h %9h Width: %0.4f %0.4f\n") + call pargd (tlngcenter) + call pargd (tlatcenter) + call pargd (dlngwidth) + call pargd (dlatwidth) + if (sk_stati (catcoo, S_NLNGUNITS) == SKY_HOURS) + call fprintf (out, "# Field Limits: %9H %9H %9h %9h\n#\n") + else + call fprintf (out, "# Field Limits: %9h %9h %9h %9h\n#\n") + call pargd (dlng1) + call pargd (dlng2) + call pargd (dlat1) + call pargd (dlat2) + } + + # Read in the data line by line, selecting the records of + # interest. + call cc_select (in, out, dc, ec, catcoo, outcoo, tlngcenter, + tlatcenter, dlngwidth, dlatwidth, dlng1, dlng2, dlat1, + dlat2, verbose) + + call close (in) + if (noutfiles == ninfiles) + call close (out) + } + + call cc_dfree (dc) + call cc_efree (ec) + + if (noutfiles != ninfiles) + call close (out) + if (fldcoo != NULL) + call sk_close (fldcoo) + call sk_close (catcoo) + if (outcoo != NULL) + call sk_close (outcoo) + call clpcls (inlist) + call clpcls (outlist) + + call sfree (sp) +end + + +# CC_LIMITS - Given the field center and field width compute the ra / +# longitude and dec / latitude limits of the region of interest. + +procedure cc_limits (catcoo, dlngcenter, dlatcenter, dlngwidth, dlatwidth, + dlng1, dlng2, dlat1, dlat2) + +pointer catcoo #I the pointer to the catalog wcs +double dlngcenter #I the field center ra / longtitude +double dlatcenter #I the field center dec / latitude +double dlngwidth #I the field ra / longitude width (degrees) +double dlatwidth #I the field dec / latitude width (degrees) +double dlng1 #O the lower field ra / longitude limit +double dlng2 #O the upper field ra / longitude limit +double dlat1 #O the lower field dec / latitude limit +double dlat2 #O the upper field dec / longitude limit + +double tlngcenter, tlatcenter, cosdec, dhlngwidth +int sk_stati() + +begin + # Convert the field center coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + tlngcenter = 15.0d0 * dlngcenter + case SKY_DEGREES: + tlngcenter = dlngcenter + case SKY_RADIANS: + tlngcenter = RADTODEG(dlngcenter) + default: + tlngcenter = dlngcenter + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + tlatcenter = 15.0d0 * dlatcenter + case SKY_DEGREES: + tlatcenter = dlatcenter + case SKY_RADIANS: + tlatcenter = RADTODEG(dlatcenter) + default: + tlatcenter = dlatcenter + } + + # Find the field corners. + dlat1 = tlatcenter - 0.5d0 * dlatwidth + if (dlat1 <= -90.0d0) { + dlat1 = -90.0d0 + dlat2 = min (tlatcenter + 0.5d0 * dlatwidth, 90.0d0) + dlng1 = 0.0d0 + dlng2 = 360.0d0 + return + } + + dlat2 = tlatcenter + 0.5d0 * dlatwidth + if (dlat2 >= 90.0d0) { + dlat2 = 90.0d0 + dlat1 = max (tlatcenter - 0.5d0 * dlatwidth, -90.0d0) + dlng1 = 0.0d0 + dlng2 = 360.0d0 + return + } + + if (tlatcenter > 0.0d0) + cosdec = cos (DEGTORAD(dlat2)) + else + cosdec = cos (DEGTORAD(dlat1)) + dhlngwidth = 0.5d0 * dlngwidth / cosdec + if (dhlngwidth >= 180.0d0) { + dlng1 = 0.0d0 + dlng2 = 360.0d0 + } else { + dlng1 = tlngcenter - dhlngwidth + if (dlng1 < 0.0d0) + dlng1 = dlng1 + 360.0d0 + dlng2 = tlngcenter + dhlngwidth + if (dlng2 > 360.0d0) + dlng2 = dlng2 - 360.0d0 + } +end + + +# CC_SELECT -- Select and print the records matching the field position +# and size criteria. + +procedure cc_select (in, out, dc, ec, catcoo, outcoo, lngcenter, latcenter, + lngwidth, latwidth, dlng1, dlng2, dlat1, dlat2, verbose) + +int in #I the input file file descriptor +int out #I the output file descriptor +pointer dc #I the file data structure +pointer ec #I the expression structure +pointer catcoo #I the input catalog coordinate structure +pointer outcoo #I the output catalog coordinate structure +double lngcenter, latcenter #I the field center coordinates +double lngwidth, latwidth #I the field widths in degrees +double dlng1, dlng2 #I the ra / longitude limits in degrees +double dlat1, dlat2 #I the dec / latitude limits in degrees +bool verbose #I verbose mode + +double dlngcenter, dlatcenter, tlng, tlat, dlng, dlat, dist +double tmplng, tlngcenter +int ip, op, i, j, nline, lngoffset, latoffset, offset1, offset2, nsig +pointer sp, inbuf, outbuf, newval, eptr, rptr, fptr, pexpr +pointer evvexpr(), locpr() +int getline(), li_get_numd(), sk_stati(), gstrcpy(), strlen() +bool streq() +extern cc_getop() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + + # Convert the field center coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + dlngcenter = 15.0d0 * lngcenter + case SKY_RADIANS: + dlngcenter = RADTODEG(lngcenter) + default: + dlngcenter = lngcenter + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + dlatcenter = 15.0d0 * latcenter + case SKY_RADIANS: + dlatcenter = RADTODEG(latcenter) + default: + dlatcenter = latcenter + } + + for (nline = 1; getline (in, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + + # Skip comment and blank lines. + if (Memc[ip] == '#') + next + else if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[DC_RECORD(dc)], SZ_LINE, TABSIZE) + call li_find_fields (Memc[DC_RECORD(dc)], Memi[DC_COFFSETS(dc)], + MAX_NCOLUMNS, DC_NCOLUMNS(dc)) + + # Decode the longitude coordinate. + if (DC_LNGCOLUMN(dc) > DC_NCOLUMNS(dc)) + next + lngoffset = Memi[DC_COFFSETS(dc)+DC_LNGCOLUMN(dc)-1] + if (li_get_numd (Memc[DC_RECORD(dc)+lngoffset-1], tlng, nsig) == 0) + next + + # Decode the latitude coordinate. + if (DC_LATCOLUMN(dc) > DC_NCOLUMNS(dc)) + next + latoffset = Memi[DC_COFFSETS(dc)+DC_LATCOLUMN(dc)-1] + if (li_get_numd (Memc[DC_RECORD(dc)+latoffset-1], tlat, nsig) == 0) + next + + # Convert the catalog coordinates to degrees. + switch (sk_stati(catcoo, S_NLNGUNITS)) { + case SKY_HOURS: + dlng = 15.0d0 * tlng + case SKY_RADIANS: + dlng = RADTODEG(tlng) + default: + dlng = tlng + } + switch (sk_stati (catcoo, S_NLATUNITS)) { + case SKY_HOURS: + dlat = 15.0d0 * tlat + case SKY_RADIANS: + dlat = RADTODEG(tlat) + default: + dlat = tlat + } + + # Test the converted ra /dec or longitude / latitude value + # versus the user defined ra / longitude and dec / latitude + # limits. + if (dlat < dlat1 || dlat > dlat2) + next + if (dlng1 < dlng2) { + if (dlng >= dlng1 && dlng <= dlng2) + ; + else + next + } else { + if (dlng > dlng2 && dlng < dlng1) + next + else + ; + } + + # Check the longitude coordinate distance to remove pathologies + # in longitude or latitude strips involving the pole. This is + # an extra test of my own. + if (dlng1 < dlng2) { + dist = abs (dlng - dlngcenter) + } else { + if (dlng > dlng1) + tmplng = dlng - 360.0d0 + else + tmplng = dlng + if (dlngcenter > dlng1) + tlngcenter = dlngcenter - 360.0d0 + else + tlngcenter = dlngcenter + dist = abs (tmplng - tlngcenter) + } + if (abs (2.0d0*dist*cos(DEGTORAD(dlat))) > lngwidth) + next + + # If all the columns are selected and no column expressions have + # been defined dump the input records to the output. + + if (outcoo == NULL && (streq (Memc[EC_ELIST(ec)], "*") || + streq (Memc[EC_ELIST(ec)], "c[*]"))) { + if (verbose && out != STDOUT) + call putline (STDOUT, Memc[DC_RECORD(dc)]) + if (out != NULL) + call putline (out, Memc[DC_RECORD(dc)]) + next + } + + # Otherwise loop through the user specified output fields + # and expressions. + + # Initialize the expression list pointers. + rptr = EC_ERANGES(ec) + eptr = EC_ELIST(ec) + fptr = EC_EFORMATS(ec) + + # Initiliaze the output buffer. + op = outbuf + Memc[op] = EOS + + do i = 1, EC_NEXPR(ec) { + + # The next user output field is an expression. + if (IS_INDEFI(Memi[rptr])) { + + pexpr = evvexpr (Memc[eptr], locpr (cc_getop), dc, 0, dc, 0) + switch (O_TYPE(pexpr)) { + case TY_BOOL: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, "%5b") + call pargi (O_VALI(pexpr)) + case TY_CHAR: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %s") + call pargstr (O_VALC(pexpr)) + case TY_INT: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10d") + call pargi (O_VALI(pexpr)) + case TY_REAL: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10g") + call pargr (O_VALR(pexpr)) + case TY_DOUBLE: + if (Memc[fptr] == '%') + call sprintf (Memc[newval], SZ_LINE, Memc[fptr]) + else + call sprintf (Memc[newval], SZ_LINE, " %10g") + call pargd (O_VALD(pexpr)) + } + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, strlen (Memc[newval]))) + + # The next user fields are columns. + } else if (Memi[rptr] >= 1 && Memi[rptr+1] <= MAX_NCOLUMNS) { + + # Transform the coordinates if necessary. + if (outcoo != NULL) + call sk_ultran (catcoo, outcoo, tlng, tlat, tlng, + tlat, 1) + + pexpr = NULL + do j = max (1, Memi[rptr]), min (Memi[rptr+1], + DC_NCOLUMNS(dc)), Memi[rptr+2] { + offset1 = Memi[DC_COFFSETS(dc)+j-1] + offset2 = Memi[DC_COFFSETS(dc)+j] + if (outcoo != NULL && offset1 == lngoffset) { + call sprintf (Memc[newval], SZ_LINE, + Memc[EC_ELNGFORMAT(ec)]) + call pargd (tlng) + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, + strlen (Memc[newval]))) + } else if (outcoo != NULL && offset1 == latoffset) { + call sprintf (Memc[newval], SZ_LINE, + Memc[EC_ELATFORMAT(ec)]) + call pargd (tlat) + op = op + gstrcpy (Memc[newval], Memc[op], + min (SZ_LINE - op + outbuf, + strlen (Memc[newval]))) + } else + op = op + gstrcpy (Memc[DC_RECORD(dc)+offset1-1], + Memc[op], min (SZ_LINE - op + outbuf, + offset2 - offset1)) + } + } + + # Update the expression list pointers. + eptr = eptr + SZ_EXPR + 1 + rptr = rptr + 3 + fptr = fptr + SZ_EFORMATS + 1 + if (pexpr != NULL) + call mfree (pexpr, TY_STRUCT) + } + + # Attach a newline and EOS to the newly formatted line and output + # it. + if (Memc[outbuf] != EOS) { + Memc[op] = '\n' + Memc[op+1] = EOS + if (verbose && out != STDOUT) + call putline (STDOUT, Memc[outbuf]) + if (out != NULL) + call putline (out, Memc[outbuf]) + } + + } + + call sfree (sp) +end + + +# CC_DINIT -- Initialize the ccget data structure. + +pointer procedure cc_dinit (cnames, lngname, latname) + +char cnames[ARB] #I optional list of columm names +char lngname[ARB] #I the ra / longitude column name or number +char latname[ARB] #I the dec / latitude column name or number + +int i, ip, op +pointer dc, cptr +int cc_cnames(), ctotok(), ctoi() +bool streq() + +begin + call calloc (dc, DC_DLENGTH, TY_STRUCT) + + # Define the column names. + call calloc (DC_COLNAMES(dc), MAX_NCOLUMNS * (SZ_COLNAME + 1), TY_CHAR) + Memc[DC_COLNAMES(dc)] = EOS + + ip = 1 + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + op = 1 + if (cc_cnames (cnames, ip, Memc[cptr], SZ_COLNAME) == EOF) { + call sprintf (Memc[cptr], SZ_COLNAME, "c%d") + call pargi (i) + } else if (ctotok (Memc[cptr], op, Memc[cptr], SZ_COLNAME) != + TOK_IDENTIFIER) { + call sprintf (Memc[cptr], SZ_COLNAME, "c%d") + call pargi (i) + } + call strlwr (Memc[cptr]) + cptr = cptr + SZ_COLNAME + 1 + } + + # Find the longitude and latitude columns. + ip = 1 + DC_LNGCOLUMN(dc) = 0 + if (ctoi (lngname, ip, DC_LNGCOLUMN(dc)) <= 0) { + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + if (streq (lngname, Memc[cptr])) { + DC_LNGCOLUMN(dc) = i + break + } + cptr = cptr + SZ_COLNAME + 1 + } + } + if (DC_LNGCOLUMN(dc) <= 0) + DC_LNGCOLUMN(dc) = 2 + + ip = 1 + DC_LATCOLUMN(dc) = 0 + if (ctoi (latname, ip, DC_LATCOLUMN(dc)) <= 0) { + cptr = DC_COLNAMES(dc) + do i = 1, MAX_NCOLUMNS { + if (streq (latname, Memc[cptr])) { + DC_LATCOLUMN(dc) = i + break + } + cptr = cptr + SZ_COLNAME + 1 + } + } + if (DC_LATCOLUMN(dc) <= 0) + DC_LATCOLUMN(dc) = DC_LNGCOLUMN(dc) + 1 + + call calloc (DC_RECORD(dc), SZ_LINE, TY_CHAR) + Memc[DC_RECORD(dc)) = EOS + + call calloc (DC_COFFSETS(dc), MAX_NCOLUMNS + 1, TY_INT) + + return (dc) +end + + +# CC_DFREE -- Free the ccget data structure. + +procedure cc_dfree (dc) + +pointer dc #U pointer to the data structure + +begin + call mfree (DC_COLNAMES(dc), TY_CHAR) + call mfree (DC_RECORD(dc), TY_CHAR) + call mfree (DC_COFFSETS(dc), TY_INT) + call mfree (dc, TY_STRUCT) +end + + +# CC_CNAMES -- Decode the list of column names into individual column names. + +int procedure cc_cnames (colnames, ip, name, maxch) + +char colnames[ARB] #I list of column names +int ip #I pointer into the list of names +char name[ARB] #O the output column name +int maxch #I 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 + } + + if (token != TOK_IDENTIFIER) { + op = 1 + next + } + + op = op + strlen (name[op]) + if (colnames[ip] == ' ') { + if (op == 1) + next + else + break + } + } + + name[op] = EOS + if ((colnames[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# CC_EINIT -- Initialize the ccget expression structure. + +pointer procedure cc_einit (exprs, formats, lngformat, latformat) + +char exprs[ARB] #I the input expression list +char formats[ARB] #I the input formats list +char lngformat[ARB] #I the input output ra / longitude format +char latformat[ARB] #I the input output dec / latitude format + +int i, ip, nexpr +pointer ec, cptr, fptr +int cc_enames() + +begin + call calloc (ec, EC_ELENGTH, TY_STRUCT) + + # Define the column names. + call malloc (EC_ELIST(ec), MAX_NEXPR * (SZ_EXPR + 1), TY_CHAR) + Memc[EC_ELIST(ec)] = EOS + + # Create list of expressions. + ip = 1 + cptr = EC_ELIST(ec) + nexpr = 0 + do i = 1, MAX_NEXPR { + if (cc_enames (exprs, ip, Memc[cptr], SZ_EXPR) == EOF) + break + call strlwr (Memc[cptr]) + cptr = cptr + SZ_EXPR + 1 + nexpr = nexpr + 1 + } + EC_NEXPR(ec) = nexpr + + + # Decode the list of expressions into column names, column ranges, + # and column expressions. + call calloc (EC_ERANGES(ec), 3 * MAX_NERANGES + 1, TY_INT) + + call calloc (EC_EFORMATS(ec), MAX_NEXPR * (SZ_EFORMATS + 1), TY_CHAR) + Memc[EC_EFORMATS(ec)] = EOS + ip = 1 + fptr = EC_EFORMATS(ec) + cptr = EC_ELIST(ec) + do i = 1, EC_NEXPR(ec) { + if (cc_enames (formats, ip, Memc[fptr], SZ_EFORMATS) == EOF) + break + fptr = fptr + SZ_EFORMATS + 1 + cptr = cptr + SZ_EXPR + 1 + } + + call calloc (EC_ELNGFORMAT(ec), SZ_EFORMATS, TY_CHAR) + call strcpy (lngformat, Memc[EC_ELNGFORMAT(ec)], SZ_EFORMATS) + call calloc (EC_ELATFORMAT(ec), SZ_EFORMATS, TY_CHAR) + call strcpy (latformat, Memc[EC_ELATFORMAT(ec)], SZ_EFORMATS) + + return (ec) +end + + +# CC_EFREE -- Free the ccget expression structure. + +procedure cc_efree (ec) + +pointer ec #U pointer to the expression structure + +begin + call mfree (EC_ELIST(ec), TY_CHAR) + call mfree (EC_ERANGES(ec), TY_INT) + call mfree (EC_EFORMATS(ec), TY_CHAR) + call mfree (EC_ELNGFORMAT(ec), TY_CHAR) + call mfree (EC_ELATFORMAT(ec), TY_CHAR) + call mfree (ec, TY_STRUCT) +end + + +# CC_ENAMES -- Decode the list of expressions into individual expressions. + +int procedure cc_enames (exprs, ip, name, maxch) + +char exprs[ARB] #I list of expressions +int ip #I pointer into the list of names +char name[ARB] #O the output column name +int maxch #I maximum length of a column name + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (exprs[ip] != EOS) { + + token = ctotok (exprs, ip, name[op], maxch) + if (name[op] == EOS) + next + + if ((token == TOK_PUNCTUATION) && (name[op] == ',')) { + if (op == 1) + next + else + break + } + + + op = op + strlen (name[op]) + } + + name[op] = EOS + if ((exprs[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + + +# CC_EDECODE -- Decode the expression list. + +procedure cc_edecode (dc, ec) + +pointer dc #I the pointer to the data structure +pointer ec #I the pointer to the expression structure + +int i, j, ip1, ip2, c1, c2, lindex, rindex, column +pointer sp, ename, eptr, cptr, rptr +char lbracket, rbracket +int ctotok(), strldx(), ctoi() +bool streq() + +begin + call smark (sp) + call salloc (ename, SZ_EXPR, TY_CHAR) + + # Initialize. + lbracket = '[' + rbracket = ']' + eptr = EC_ELIST(ec) + rptr = EC_ERANGES(ec) + + do i = 1, EC_NEXPR(ec) { + + ip1 = 1 + lindex = strldx (lbracket, Memc[eptr]) + rindex = strldx (rbracket, Memc[eptr]) + ip2 = lindex + 1 + if (Memc[eptr] == 'c' && lindex == 2 && rindex > lindex) { + if (Memc[eptr+lindex] == '*') { + c1 = 1 + c2 = MAX_NCOLUMNS + } else { + if (ctoi (Memc[eptr], ip2, c1) <= 0) + c1 = 0 + else if (c1 < 1 || c1 > MAX_NCOLUMNS) + c1 = 0 + if (ctoi (Memc[eptr], ip2, c2) <= 0) + c2 = 0 + else + c2 = -c2 + if (c2 < 1 || c2 > MAX_NCOLUMNS) + c2 = 0 + } + + if (c1 > 0 && c2 > c1) { + Memi[rptr] = c1 + Memi[rptr+1] = c2 + Memi[rptr+2] = 1 + } + } else if (ctotok (Memc[eptr], ip1, Memc[ename], SZ_EXPR) == + TOK_IDENTIFIER) { + cptr = DC_COLNAMES(dc) + column = 0 + do j = 1, MAX_NCOLUMNS { + if (streq (Memc[eptr], Memc[cptr])) { + column = j + break + } + cptr = cptr + SZ_COLNAME + 1 + } + if (column > 0) { + Memi[rptr] = j + Memi[rptr+1] = j + Memi[rptr+2] = 1 + } else if (ctotok (Memc[eptr], ip1, Memc[ename], SZ_EXPR) != + EOS) { + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + } + } else { + Memi[rptr] = INDEFI + Memi[rptr+1] = INDEFI + Memi[rptr+2] = INDEFI + } + eptr = eptr + SZ_EXPR + 1 + rptr = rptr + 3 + } + + call sfree (sp) +end + + +# CC_GETOP -- Fetch an operand from the data structure. + +procedure cc_getop (dc, operand, o) + +pointer dc #I pointer to the data structure +char operand[ARB] #I name of operand to be returned +pointer o #I pointer to output operand + +int ip, column, offset, csize, type, nchars +pointer cptr +bool streq() +int lexnum(), ctod(), ctoi() + +begin + # Find the symbol. + cptr = DC_COLNAMES(dc) + column = 0 + do ip = 1, MAX_NCOLUMNS { + if (streq (operand, Memc[cptr])) { + column = ip + break + } + cptr = cptr + SZ_COLNAME + 1 + } + if (column <= 0) + call xvv_error1 ("Column '%s' not found", operand[1]) + + # Find column pointer. + offset = Memi[DC_COFFSETS(dc)+column-1] + csize = Memi[DC_COFFSETS(dc)+column] - offset + cptr = DC_RECORD(dc)+offset-1 + + # Determine the type of the symbol. + ip = 1 + type = lexnum (Memc[cptr], ip, nchars) + #if (Memc[cptr+nchars+ip-1] != EOS) + #type = LEX_NONNUM + + # Decode the symbol. + switch (type) { + case LEX_OCTAL, LEX_DECIMAL, LEX_HEX: + call xvv_initop (o, 0, TY_INT) + ip = 1 + nchars = ctoi (Memc[cptr], ip, O_VALI(o)) + case LEX_REAL: + call xvv_initop (o, 0, TY_DOUBLE) + ip = 1 + nchars = ctod (Memc[cptr], ip, O_VALD(o)) + case LEX_NONNUM: + call xvv_initop (o, csize, TY_CHAR) + call strcpy (Memc[cptr], O_VALC(o), csize) + } +end diff --git a/pkg/images/imcoords/src/t_ccmap.x b/pkg/images/imcoords/src/t_ccmap.x new file mode 100644 index 00000000..969438be --- /dev/null +++ b/pkg/images/imcoords/src/t_ccmap.x @@ -0,0 +1,2079 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "../../lib/geomap.h" + +# Define the source of the reference point. +define CC_REFPOINTSTR "|coords|user|tweak|" +define CC_COORDS 1 +define CC_USER 2 +define CC_TWEAK 3 + +# Define the possible pixel types. +define CC_PIXTYPESTR "|logical|physical|" +define CC_LOGICAL 1 +define CC_PHYSICAL 2 + +# Define some limits on the input file +define MAX_FIELDS 100 # the max number of fields in the list +define TABSIZE 8 # the spacing of the tab stops + +# Define the default data buffer size +define CC_DEFBUFSIZE 1000 # the default buffer size + +# T_CCMAP -- Compute the linear portion of the transformation required +# to convert image x and y coordinates to ra / longitude and dec / latitude +# coordinates. This version allows combining multiple inputs with different +# tangent points (as in a dither set) to create a single solution. + +procedure t_ccmap () + +pointer in, im, tdxref, tdyref, tdlngref, tdlatref +pointer sp, infile, image, database, insystem, refsystem, str +pointer xref, yref, lngref, latref +pointer graphics, coo, refcoo, tcoo, mw, fit, out, gd, projstr +double dxref, dyref, dlngref, dlatref, xmin, xmax, ymin, ymax, reject +int i, inlist, ninfiles, nin, imlist, nimages, coostat, refstat, nchars, ip +int xreflist, yreflist, lngreflist, latreflist +int xcolumn, ycolumn, lngcolumn, latcolumn, lngunits, latunits, res, pfd +int lngrefunits, latrefunits, refpoint_type, tweak, projection +int reslist, nresfiles +int geometry, function, xxorder, xyorder, xxterms, yxorder, yyorder, yxterms +int reclist, nrecords, pixsys, maxiter +bool verbose, update, interactive + +double clgetd() +pointer dtmap(), immap(), gopen(), cc_utan(), cc_imtan() +int clpopnu(), clplen(), imtopenp(), imtlen(), clgeti(), clgwrd(), strlen() +int sk_decwcs(), sk_stati(), imtgetim(), clgfil(), open(), ctod() +int errget(), imtopen(), strncmp(), cc_rdproj(), strdic() +bool clgetb() +errchk open(), cc_map() + +begin + # Get some working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (xref, SZ_FNAME, TY_CHAR) + call salloc (yref, SZ_FNAME, TY_CHAR) + call salloc (lngref, SZ_FNAME, TY_CHAR) + call salloc (latref, SZ_FNAME, TY_CHAR) + call salloc (refsystem, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input data file list. + inlist = clpopnu ("input") + ninfiles = clplen (inlist) + if (ninfiles <= 0) { + call eprintf ("Error: The input coordinate file list is empty\n") + call clpcls (inlist) + call sfree (sp) + return + } + + # Open the database output file. + call clgstr ("database", Memc[database], SZ_FNAME) + out = dtmap (Memc[database], APPEND) + + # Open the record list. + call clgstr ("solutions", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + reclist = NULL + nrecords = 0 + } else { + reclist = imtopen (Memc[str]) + nrecords = imtlen (reclist) + } + if (nrecords > 1 && nrecords != ninfiles) { + call eprintf ("Error: List of record names does not match input\n") + call clpcls (inlist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the input image list. + imlist = imtopenp ("images") + nimages = imtlen (imlist) + if (nimages > 1 && nimages != ninfiles) { + call eprintf ("Error: Coordinate files and images don't match\n") + call imtclose (imlist) + call clpcls (inlist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the output results lists. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != ninfiles) { + call eprintf ("Error: List of results files does not match input\n") + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the coordinates file format. + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the reference point parameters. + refpoint_type = clgwrd ("refpoint", Memc[str], SZ_FNAME, + CC_REFPOINTSTR) + tweak = refpoint_type + xreflist = clpopnu ("xref") + yreflist = clpopnu ("yref") + lngreflist = clpopnu ("lngref") + latreflist = clpopnu ("latref") + call clgstr ("refsystem", Memc[refsystem], SZ_FNAME) + if (strncmp (Memc[refsystem], "INDEF", 5) == 0) + Memc[refsystem] = EOS + iferr (lngrefunits = clgwrd ("lngrefunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngrefunits = 0 + iferr (latrefunits = clgwrd ("latrefunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latrefunits = 0 + + # Get the minimum and maximum reference values. + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + + # Get the coordinate mapping parameters. + call clgstr ("projection", Memc[str], SZ_LINE) + iferr { + pfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } then { + projection = strdic (Memc[str], Memc[str], SZ_LINE, GM_PROJLIST) + if (projection <= 0 || projection == WTYPE_LIN) + Memc[projstr] = EOS + else + call strcpy (Memc[str], Memc[projstr], SZ_LINE) + } else { + projection = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + geometry = clgwrd ("fitgeometry", Memc[str], SZ_LINE, GM_GEOMETRIES) + function = clgwrd ("function", Memc[str], SZ_LINE, GM_FUNCS) + xxorder = clgeti ("xxorder") + xyorder = clgeti ("xyorder") + xxterms = clgwrd ("xxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + yxorder = clgeti ("yxorder") + yyorder = clgeti ("yyorder") + yxterms = clgwrd ("yxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + maxiter = clgeti ("maxiter") + reject = clgetd ("reject") + + # Get the input and output parameters. + update = clgetb ("update") + iferr (pixsys = clgwrd ("pixsystem", Memc[str], SZ_FNAME, + CC_PIXTYPESTR)) + pixsys = PIXTYPE_LOGICAL + else if (pixsys == CC_PHYSICAL) + pixsys = PIXTYPE_PHYSICAL + else + pixsys = PIXTYPE_LOGICAL + verbose = clgetb ("verbose") + + # Open the input coordinate system. + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error: Cannot decode the input coordinate system\n") + if (mw != NULL) + call mw_close (mw) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call dtunmap (out) + call sfree (sp) + return + } + + # Determine the units of the input coordinate system. + if (lngunits <= 0) + lngunits = sk_stati (coo, S_NLNGUNITS) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits <= 0) + latunits = sk_stati (coo, S_NLATUNITS) + call sk_seti (coo, S_NLATUNITS, latunits) + call sk_seti (coo, S_PIXTYPE, pixsys) + + # Set default reference coordinate. + Memc[xref] = EOS + Memc[yref] = EOS + Memc[lngref] = EOS + Memc[latref] = EOS + + # Open the reference coordinate system if possible. + refstat = sk_decwcs (Memc[refsystem], mw, refcoo, NULL) + if (refstat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + refcoo = NULL + if (lngrefunits <= 0) + lngrefunits = sk_stati (coo, S_NLNGUNITS) + if (latrefunits <= 0) + latrefunits = sk_stati (coo, S_NLATUNITS) + } else { + if (lngrefunits <= 0) + lngrefunits = sk_stati (refcoo, S_NLNGUNITS) + call sk_seti (refcoo, S_NLNGUNITS, lngrefunits) + if (latrefunits <= 0) + latrefunits = sk_stati (refcoo, S_NLATUNITS) + call sk_seti (refcoo, S_NLATUNITS, latrefunits) + } + + # Get the graphics parameters. + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the coordinate mapping structure. + call geo_minit (fit, projection, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + call strcpy (Memc[projstr], GM_PROJSTR(fit), SZ_LINE) + + # Process the input. + call calloc (in, ninfiles, TY_INT) + call calloc (im, ninfiles, TY_POINTER) + call calloc (tdxref, ninfiles, TY_DOUBLE) + call calloc (tdyref, ninfiles, TY_DOUBLE) + call calloc (tdlngref, ninfiles, TY_DOUBLE) + call calloc (tdlatref, ninfiles, TY_DOUBLE) + call amovkd (INDEFD, Memd[tdxref], ninfiles) + call amovkd (INDEFD, Memd[tdyref], ninfiles) + call amovkd (INDEFD, Memd[tdlngref], ninfiles) + call amovkd (INDEFD, Memd[tdlatref], ninfiles) + + # Loop over the files. This is a little messy in order to allow + # both the case where all inputs are combined or separately done. + repeat { + + nin = 0 + while (clgfil (inlist, Memc[infile], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + Memi[in+nin] = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Open the input image. + if (nimages > 0) { + if (imtgetim (imlist, Memc[image], SZ_FNAME) == EOF) { + Memi[im+nin] = NULL + } else if (update) { + Memi[im+nin] = immap (Memc[image], READ_WRITE, 0) + } else { + Memi[im+nin] = immap (Memc[image], READ_ONLY, 0) + } + if (Memi[im+nin] != NULL) { + if (IM_NDIM(Memi[im+nin]) != 2) { + call printf ("Skipping file: %s Image: %s is not 2D\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call imunmap (Memi[im+nin]) + next + } + } else + Memc[image] = EOS + } else { + Memi[im+nin] = NULL + Memc[image] = EOS + } + + if (nin == 0) { + + # Open the results file. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + else + res = NULL + + # Set the output file record name. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else if (Memi[im] == NULL) { + call strcpy (Memc[infile], GM_RECORD(fit), SZ_FNAME) + } else { + #call imgimage (Memc[image], Memc[str], SZ_FNAME) + call strcpy (Memc[image], GM_RECORD(fit), SZ_FNAME) + } + } + + # Determine the coordinates of the reference point if possible. + if (clgfil (xreflist, Memc[xref], SZ_FNAME) == EOF) + ; + if (clgfil (yreflist, Memc[yref], SZ_FNAME) == EOF) + ; + if (clgfil (lngreflist, Memc[lngref], SZ_FNAME) == EOF) + ; + if (clgfil (latreflist, Memc[latref], SZ_FNAME) == EOF) + ; + ip = 1 + nchars = ctod (Memc[xref], ip, dxref) + if (nchars <= 0 || nchars != strlen (Memc[xref])) + dxref = INDEFD + ip = 1 + nchars = ctod (Memc[yref], ip, dyref) + if (nchars <= 0 || nchars != strlen (Memc[yref])) + dyref = INDEFD + ip = 1 + nchars = ctod (Memc[lngref], ip, dlngref) + if (nchars <= 0 || nchars != strlen (Memc[lngref])) + dlngref = INDEFD + if (dlngref < 0.0d0 || dlngref > 360.0d0) + dlngref = INDEFD + ip = 1 + nchars = ctod (Memc[latref], ip, dlatref) + if (nchars <= 0 || nchars != strlen (Memc[latref])) + dlatref = INDEFD + if (dlatref < -90.0d0 || dlatref > 90.0d0) + dlatref = INDEFD + + Memd[tdxref+nin] = dxref + Memd[tdyref+nin] = dyref + Memd[tdlngref+nin] = dlngref + Memd[tdlatref+nin] = dlatref + + # Determine the tangent points and convert them to the + # celestial coordinate system of the input data, + + # The tangent point will be determined directly from + # the input coordinates. + if (refpoint_type == CC_COORDS) { + + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[insystem], + NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[insystem], + NULL, coo) + } + Memd[tdxref+nin] = INDEFD + Memd[tdyref+nin] = INDEFD + Memd[tdlngref+nin] = INDEFD + Memd[tdlatref+nin] = INDEFD + + # The tangent point was set by the user and a tangent point + # reference system may or may not have been defined. + } else if (! IS_INDEFD(dlngref) && ! IS_INDEFD (dlatref)) { + + tcoo = cc_utan (refcoo, coo, dxref, dyref, dlngref, dlatref, + Memd[tdlngref+nin], Memd[tdlatref+nin], + lngrefunits, latrefunits) + call sk_stats (tcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[str], NULL, tcoo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[str], + NULL, tcoo) + call sk_close (tcoo) + } + + } else if (Memi[im+nin] != NULL) { + + tcoo = cc_imtan (Memi[im+nin], Memc[xref], Memc[yref], + Memc[lngref], Memc[latref], Memc[refsystem], + refcoo, coo, Memd[tdxref+nin], Memd[tdyref+nin], + Memd[tdlngref+nin], Memd[tdlatref+nin], + lngrefunits, latrefunits) + call sk_stats (tcoo, S_COOSYSTEM, Memc[str], SZ_FNAME) + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[str], NULL, tcoo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[str], + NULL, tcoo) + call sk_close (tcoo) + } + + # The tangent point will be determined directly from + # the input coordinates. + } else { + + if (nin == 0) { + if (verbose && res != STDOUT) + call sk_iiprint ("Refsystem", Memc[insystem], + NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Refsystem", Memc[insystem], + NULL, coo) + } + Memd[tdxref+nin] = INDEFD + Memd[tdyref+nin] = INDEFD + Memd[tdlngref+nin] = INDEFD + Memd[tdlatref+nin] = INDEFD + + } + + if (nin == 0) { + # Print information about the input coordinate system. + if (verbose && res != STDOUT) + call sk_iiprint ("Insystem", Memc[insystem], NULL, coo) + if (res != NULL) + call sk_iiwrite (res, "Insystem", Memc[insystem], + NULL, coo) + } + + # Print the input and out file information. + if (verbose && res != STDOUT) { + call printf ("\nCoords File: %s Image: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call printf (" Database: %s Solution: %s\n") + call pargstr (Memc[database]) + call pargstr (GM_RECORD(fit)) + } + if (res != NULL) { + call fprintf (res, "\n# Coords File: %s Image: %s\n") + call pargstr (Memc[infile]) + call pargstr (Memc[image]) + call fprintf (res, "# Database: %s Solution: %s\n") + call pargstr (Memc[database]) + call pargstr (GM_RECORD(fit)) + } + + nin = nin + 1 + if (nrecords > 1 || nresfiles > 1) + break + } + if (nin == 0) + break + + iferr { + if (interactive) + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + else + gd = NULL + call cc_map (gd, nin, Memi[in], out, Memi[im], res, coo, fit, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + Memd[tdxref], Memd[tdyref], Memd[tdlngref], Memd[tdlatref], + xmin, xmax, ymin, ymax, update, verbose) + if (gd != NULL) + call gclose (gd) + } then { + if (verbose && res != STDOUT) { + if (nin == 1) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[infile]) + } else + call printf ("Error fitting coordinate lists\n") + call flush (STDOUT) + Memc[str] = EOS + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf (" %s\n") + call pargstr (Memc[str]) + } + if (res != NULL) { + if (nin == 1) { + call fprintf (res, + "# Error fitting coordinate list: %s\n") + call pargstr (Memc[infile]) + } else + call fprintf (res, + "# Error fitting coordinate lists\n") + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str]) + } + if (gd != NULL) + call gclose (gd) + } + + + if (nresfiles == ninfiles) + call close (res) + do i = 1, nin { + call close (Memi[in+i-1]) + if (Memi[im+i-1] != NULL) + call imunmap (Memi[im+i-1]) + } + } + + call mfree (in, TY_INT) + call mfree (im, TY_POINTER) + call mfree (tdxref, TY_DOUBLE) + call mfree (tdyref, TY_DOUBLE) + call mfree (tdlngref, TY_DOUBLE) + call mfree (tdlatref, TY_DOUBLE) + + call geo_free (fit) + call sk_close (coo) + call clpcls (xreflist) + call clpcls (yreflist) + call clpcls (latreflist) + call clpcls (lngreflist) + if (nresfiles < ninfiles) + call close (res) + call dtunmap (out) + if (reclist != NULL) + call imtclose (reclist) + call imtclose (imlist) + call clpcls (inlist) + call clpcls (reslist) + call sfree (sp) +end + + +# CC_UTAN -- Convert the user defined tangent point from the reference +# point celestial coordinate system to the input coordinate celestial +# coordinate system. + +pointer procedure cc_utan (refcoo, coo, idxref, idyref, idlngref, idlatref, odlngref, odlatref, + lngrefunits, latrefunits) + +pointer refcoo #I pointer to the reference point system +pointer coo #I pointer to the input coordinate system +double idxref #I the input x reference point +double idyref #I the input y reference point +double idlngref #I the input reference point ra / longitude +double idlatref #I the input reference point dec / latitude +double odxref #O the output x reference point +double odyref #O the output y reference point +double odlngref #O the output reference point ra / longitude +double odlatref #O the output reference point dec / latitude +int lngrefunits #I the input reference ra / longitude units +int latrefunits #I the input reference dec / latitude units + +pointer trefcoo +pointer sk_copy() + +begin + odxref = idxref + odyref = idyref + if (refcoo != NULL) { + trefcoo = sk_copy (refcoo) + } else { + trefcoo = sk_copy (coo) + call sk_seti (trefcoo, S_NLNGUNITS, lngrefunits) + call sk_seti (trefcoo, S_NLATUNITS, latrefunits) + } + call sk_ultran (trefcoo, coo, idlngref, idlatref, odlngref, odlatref, 1) + + return (trefcoo) +end + + +# CC_IMTAN -- Read the tangent point from the image and convert it from the +# reference point celestial coordinate system to the input coordinate celestial +# coordinate system. + +pointer procedure cc_imtan (im, xref, yref, lngref, latref, refsystem, refcoo, + coo, odxref, odyref, odlngref, odlatref, lngrefunits, latrefunits) + +pointer im #I pointer to the input image +char xref[ARB] #I the x reference keyword +char yref[ARB] #I the y reference keyword +char lngref[ARB] #I the ra / longitude keyword +char latref[ARB] #I the dec / latitude keyword +char refsystem[ARB] #I the reference point coordinate system +pointer refcoo #I pointer to the reference point system +pointer coo #I pointer to the input coordinate system +double odxref #O the output x reference point +double odyref #O the output y reference point +double odlngref #O the output reference point ra / longitude +double odlatref #O the output reference point dec / latitude +int lngrefunits #I the input reference ra / longitude units +int latrefunits #I the input reference dec / latitude units + +double idxref, idyref, idlngref, idlatref, idepoch +pointer sp, str, tcoo, mw +double imgetd() +pointer sk_copy() +int sk_decwcs() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + iferr (idxref = imgetd (im, xref)) + idxref = INDEFD + iferr (idyref = imgetd (im, yref)) + idyref = INDEFD + iferr (idlngref = imgetd (im, lngref)) + idlngref = INDEFD + if (idlngref < 0.0d0 || idlngref > 360.0d0) + idlngref = INDEFD + iferr (idlatref = imgetd (im, latref)) + idlatref = INDEFD + if (idlatref < -90.0d0 || idlatref > 90.0d0) + idlatref = INDEFD + + if (!IS_INDEFD(idxref)) + odxref = idxref + if (!IS_INDEFD(idyref)) + odyref = idyref + + if (IS_INDEFD(idlngref) || IS_INDEFD(idlatref)) + tcoo = sk_copy (coo) + else if (refcoo != NULL) { + tcoo = sk_copy (refcoo) + call sk_ultran (tcoo, coo, idlngref, idlatref, odlngref, + odlatref, 1) + } else { + iferr (idepoch = imgetd (im, refsystem)) + idepoch = INDEFD + if (IS_INDEFD(idepoch)) + tcoo = sk_copy (coo) + else { + call sprintf (Memc[str], SZ_FNAME, "fk4 b%g") + call pargd (idepoch) + if (sk_decwcs (Memc[str], mw, tcoo, NULL) == ERR) { + call sk_close (tcoo) + tcoo = sk_copy (coo) + } + if (mw != NULL) + call mw_close (mw) + } + call sk_seti (tcoo, S_NLNGUNITS, lngrefunits) + call sk_seti (tcoo, S_NLATUNITS, latrefunits) + call sk_ultran (tcoo, coo, idlngref, idlatref, odlngref, + odlatref, 1) + } + + call sfree (sp) + + return (tcoo) +end + + +# CC_MAP -- Compute the required coordinate transformation. +# +# This version uses the nin variable. + +procedure cc_map (gd, nin, in, out, im, res, coo, fit, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xtan, ytan, ratan, dectan, + xmin, xmax, ymin, ymax, update, verbose) + +pointer gd #I graphics stream pointer +int nin #I number of input files +int in[ARB] #I the input file descriptors +pointer out #I the output file descriptor +pointer im[ARB] #I the input image pointers +int res #I the results file descriptor +pointer coo # pointer to the input coordinate system +pointer fit #I pointer to fit parameters +int xcolumn, ycolumn #I the x and y column numbers +int lngcolumn, latcolumn #I the longitude and latitude column numbers +int tweak #I tweak flag +double xtan[ARB], ytan[ARB] #I the input x and y of the tangent point +double ratan[ARB], dectan[ARB] #I the input ra and dec of the tangent point +double xmin, xmax #I max and min xref values +double ymin, ymax #I max and min yref values +bool update #I update the image wcs +bool verbose #I verbose mode + +double mintemp, maxtemp, lngrms, latrms, lngmean, latmean +pointer sp, str, projstr +pointer n, xref, yref, xifit, etafit, lngfit, latfit, wts +pointer lngref, latref, xi, eta, lngref1, latref1, xi1, eta1 +pointer sx1, sy1, sx2, sy2, xerrmsg, yerrmsg +int i, npts, npts1 +double asumd() +int cc_rdxyrd(), sk_stati(), rg_wrdstr() +bool streq() + +errchk geo_fitd, geo_mgfitd() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize the pointers. + xref = NULL + yref = NULL + lngref = NULL + latref = NULL + xi = NULL + eta = NULL + xifit = NULL + etafit = NULL + lngfit = NULL + latfit = NULL + wts = NULL + + # Read in data and check that it is in range. + if (gd != NULL) + call gdeactivate (gd, 0) + npts = cc_rdxyrd (in, im, xtan, ytan, ratan, dectan, nin, + coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + n, xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + if (gd != NULL) + call greactivate (gd, 0) + if (npts == 0) + return + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = asumd (Memd[xref], npts) / npts + GM_YOREF(fit) = asumd (Memd[yref], npts) / npts + GM_XOIN(fit) = asumd (Memd[lngref], npts) / npts + GM_YOIN(fit) = asumd (Memd[latref], npts) / npts + + # Set the sky projection str. + if (rg_wrdstr (GM_PROJECTION(fit), Memc[projstr], SZ_LINE, + GM_PROJLIST) <= 0 || GM_PROJECTION(fit) == GM_LIN) + Memc[projstr] = EOS + else + call strcpy (GM_PROJSTR(fit), Memc[projstr], SZ_LINE) + + # Compute the position of the reference point for the solution. + if (IS_INDEFD(ratan[1]) || IS_INDEFD(dectan[1])) { + call cc_refpt (coo, Memd[lngref], Memd[latref], npts, + lngmean, latmean) + if (IS_INDEFD(ratan[1])) + GM_XREFPT(fit) = lngmean + else + GM_XREFPT(fit) = ratan[1] + if (IS_INDEFD(dectan[1])) + GM_YREFPT(fit) = latmean + else + GM_YREFPT(fit) = dectan[1] + } else { + GM_XREFPT(fit) = ratan[1] + GM_YREFPT(fit) = dectan[1] + } + + # Allocate space for and compute the weights. + call malloc (wts, npts, TY_DOUBLE) + call amovkd (double(1.), Memd[wts], npts) + + # Determine the x max and min. + if (IS_INDEFD(xmin) || IS_INDEFD(xmax)) { + call alimd (Memd[xref], npts, mintemp, maxtemp) + if (! IS_INDEFD(xmin)) + GM_XMIN(fit) = xmin + else + GM_XMIN(fit) = mintemp + if (! IS_INDEFD(xmax)) + GM_XMAX(fit) = xmax + else + GM_XMAX(fit) = maxtemp + } else { + GM_XMIN(fit) = xmin + GM_XMAX(fit) = xmax + } + + # Determine the y max and min. + if (IS_INDEFD(ymin) || IS_INDEFD(ymax)) { + call alimd (Memd[yref], npts, mintemp, maxtemp) + if (! IS_INDEFD(ymin)) + GM_YMIN(fit) = ymin + else + GM_YMIN(fit) = mintemp + if (! IS_INDEFD(ymax)) + GM_YMAX(fit) = ymax + else + GM_YMAX(fit) = maxtemp + } else { + GM_YMIN(fit) = ymin + GM_YMAX(fit) = ymax + } + + # Convert the ra / longitude and dec / latitude values to standard + # coordinates in arc seconds before fitting. + call malloc (xi, npts, TY_DOUBLE) + call malloc (eta, npts, TY_DOUBLE) + lngref1 = lngref; latref1 = latref; xi1 = xi; eta1 = eta + do i = 1, nin { + npts1 = Memi[n+i-1] + if (npts1 == 0) + next + if (IS_INDEFD(ratan[i]) || IS_INDEFD(dectan[i])) + call rg_celtostd (Memc[projstr], Memd[lngref1], Memd[latref1], + Memd[xi1], Memd[eta1], npts1, lngmean, latmean, + sk_stati(coo, S_NLNGUNITS), sk_stati(coo, S_NLATUNITS)) + else + call rg_celtostd (Memc[projstr], Memd[lngref1], Memd[latref1], + Memd[xi1], Memd[eta1], npts1, ratan[i], dectan[i], + sk_stati(coo, S_NLNGUNITS), sk_stati(coo, S_NLATUNITS)) + lngref1 = lngref1 + npts1 + latref1 = latref1 + npts1 + xi1 = xi1 + npts1 + eta1 = eta1 + npts1 + } + call amulkd (Memd[xi], 3600.0d0, Memd[xi], npts) + call amulkd (Memd[eta], 3600.0d0, Memd[eta], npts) + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (! (IS_INDEFD(xtan[1]) || IS_INDEFD(ytan[1]))) { + call geo_setd (fit, GMXO, xtan[1]) + call geo_setd (fit, GMYO, ytan[1]) + call geo_setd (fit, GMXOREF, 0D0) + call geo_setd (fit, GMYOREF, 0D0) + } + if (gd != NULL) { + iferr { + call geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xi], Memd[eta], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xi, TY_DOUBLE) + call mfree (eta, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few data points in XI or ETA fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) + call fprintf (res, "# Coordinate mapping status\n") + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fitd (fit, sx1, sy1, sx2, sy2, Memd[xref], Memd[yref], + Memd[xi], Memd[eta], Memd[wts], npts, Memc[xerrmsg], + Memc[yerrmsg], SZ_LINE) + } then { + #call printf ("%s %s\n") + #call pargstr (Memc[xerrmsg]) + #call pargstr (Memc[yerrmsg]) + #call flush (STDOUT) + call mfree (xi, TY_DOUBLE) + call mfree (eta, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few data points in XI or ETA fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + } + } + + # Allocate fitting arrays. + call malloc (xifit, npts, TY_DOUBLE) + call malloc (etafit, npts, TY_DOUBLE) + call malloc (lngfit, npts, TY_DOUBLE) + call malloc (latfit, npts, TY_DOUBLE) + + # Compute the fitted ra / dec or longitude latitude, + if (res != NULL || verbose) { + call cc_eval (sx1, sy1, sx2, sy2, Memd[xref], Memd[yref], + Memd[xifit], Memd[etafit], npts) + call cc_rms (fit, Memd[xi], Memd[eta], Memd[xifit], Memd[etafit], + Memd[wts], npts, lngrms, latrms) + call adivkd (Memd[xifit], 3600.0d0, Memd[xifit], npts) + call adivkd (Memd[etafit], 3600.0d0, Memd[etafit], npts) + call rg_stdtocel (Memc[projstr], Memd[xifit], Memd[etafit], + Memd[lngfit], Memd[latfit], npts, GM_XREFPT(fit), + GM_YREFPT(fit), sk_stati(coo, S_NLNGUNITS), sk_stati(coo, + S_NLATUNITS)) + } + + # Print some detailed info about the fit. + if (verbose && res != STDOUT) { + call printf ( + " Ra/Dec or Long/Lat fit rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + call cc_show (STDOUT, coo, Memc[projstr], GM_XREFPT(fit), + GM_YREFPT(fit), sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, + "# Ra/Dec or Long/Lat fit rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + call cc_show (res, coo, Memc[projstr], GM_XREFPT(fit), + GM_YREFPT(fit), sx1, sy1, YES) + } + + # Compute the wcs mapping rms. + if (! streq (GM_PROJSTR(fit), "tnx") && ! streq (GM_PROJSTR(fit), + "zpx")) { + call cc_eval (sx1, sy1, NULL, NULL, Memd[xref], Memd[yref], + Memd[xifit], Memd[etafit], npts) + call cc_rms (fit, Memd[xi], Memd[eta], Memd[xifit], + Memd[etafit], Memd[wts], npts, lngrms, latrms) + } + + # Update the image wcs. + do i = 1, nin { + if (im[i] != NULL) { + if (i == 1) { + if (verbose && res != STDOUT) { + call printf ("Wcs mapping status\n") + call printf ( + " Ra/Dec or Long/Lat wcs rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + } + if (res != NULL) { + call fprintf (res, "# Wcs mapping status\n") + call fprintf (res, + "# Ra/Dec or Long/Lat wcs rms: %0.3g %0.3g (arcsec arcsec)\n") + call pargd (lngrms) + call pargd (latrms) + } + } + if (update) { + if (IS_INDEFD(ratan[i]) || IS_INDEFD(dectan[i])) + call cc_nwcsim (im[i], coo, Memc[projstr], lngmean, + latmean, sx1, sy1, sx2, sy2, false) + else + call cc_nwcsim (im[i], coo, Memc[projstr], ratan[i], + dectan[i], sx1, sy1, sx2, sy2, false) + if (i == 1) { + if (verbose && res != STDOUT) + call printf ("Updating image header wcs\n\n") + if (res != NULL) + call fprintf (res, + "# Updating image header wcs\n\n") + } + } + } + } + + # Write the database file. + call cc_out (fit, coo, out, sx1, sy1, sx2, sy2, lngrms, latrms) + + # List results for individual objects. + if (res != NULL) + call cc_plist (res, fit, coo, Memd[xref], Memd[yref], Memd[lngref], + Memd[latref], Memd[lngfit], Memd[latfit], Memd[wts], + npts) + + # Free the space and close files. + call geo_mmfreed (sx1, sy1, sx2, sy2) + + if (n != NULL) + call mfree (n, TY_INT) + if (xref != NULL) + call mfree (xref, TY_DOUBLE) + if (yref != NULL) + call mfree (yref, TY_DOUBLE) + if (lngref != NULL) + call mfree (lngref, TY_DOUBLE) + if (latref != NULL) + call mfree (latref, TY_DOUBLE) + if (xi != NULL) + call mfree (xi, TY_DOUBLE) + if (eta != NULL) + call mfree (eta, TY_DOUBLE) + if (xifit != NULL) + call mfree (xifit, TY_DOUBLE) + if (etafit != NULL) + call mfree (etafit, TY_DOUBLE) + if (wts != NULL) + call mfree (wts, TY_DOUBLE) + if (lngfit != NULL) + call mfree (lngfit, TY_DOUBLE) + if (latfit != NULL) + call mfree (latfit, TY_DOUBLE) + + call sfree (sp) +end + + +# CC_RDXYRD -- Read in the x, y, ra, and dec values from the input file(s). +# +# Adjust the tangent points if there is an image WCS. + +int procedure cc_rdxyrd (in, im, xtan, ytan, ratan, dectan, nin, + coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + n, xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + +int in[nin] #I the input file file descriptors +pointer im[nin] #I the input image pointers +double xtan[ARB], ytan[ARB] #I the input x and y of the tangent point +double ratan[ARB], dectan[ARB] #I the input ra and dec of the tangent point +int nin #I number of input files +pointer coo #I the input coordinate system +int xcolumn, ycolumn #I the columns containing the x / y values +int lngcolumn, latcolumn #I the columns containing the lng / lat values +int tweak #I tweak flag +pointer n #U pointer to the number of points +pointer xref, yref #I pointers to the x / y value arrays +pointer lngref, latref #I pointers to the lng / lat value arrays +double xmin, xmax #U the min and max x values +double ymin, ymax #U the min and max y values + +int i, npts, npts1 +pointer xref1, yref1, lngref1, latref1 + +int cc_rdxyrd1() + +begin + call calloc (n, nin, TY_INT) + + npts = 0 + do i = 1, nin { + npts1 = cc_rdxyrd1 (in[i], im[i], xtan[i], ytan[i], ratan[i], + dectan[i], coo, xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xref1, yref1, lngref1, latref1, xmin, xmax, ymin, ymax) + Memi[n+i-1] = npts1 + if (npts1 == 0) + next + if (npts == 0) { + xref = xref1 + yref = yref1 + lngref = lngref1 + latref = latref1 + } else { + call realloc (xref, npts+npts1, TY_DOUBLE) + call realloc (yref, npts+npts1, TY_DOUBLE) + call realloc (lngref, npts+npts1, TY_DOUBLE) + call realloc (latref, npts+npts1, TY_DOUBLE) + call amovd (Memd[xref1], Memd[xref+npts], npts1) + call amovd (Memd[yref1], Memd[yref+npts], npts1) + call amovd (Memd[lngref1], Memd[lngref+npts], npts1) + call amovd (Memd[latref1], Memd[latref+npts], npts1) + call mfree (xref1, TY_DOUBLE) + call mfree (yref1, TY_DOUBLE) + call mfree (lngref1, TY_DOUBLE) + call mfree (latref1, TY_DOUBLE) + } + npts = npts + npts1 + } + + if (npts == 0) { + call mfree (n, TY_INT) + + if (i > 1) + call printf ("Coordinate lists have no data in range.\n") + } + + return (npts) +end + + +# CC_RDXYRD1 -- Read in the x, y, ra, and dec values from the input file. +# +# If a reference point (both pixel and value) and an image (with a +# valid celestial WCS) are defined then the WCS is reset to the reference +# point and the reference point value is then shifted to make the +# the WCS coordinates evaluated at the input pixel coordinates agree +# if the input celestial coordinates on average. + +int procedure cc_rdxyrd1 (in, im, xtan, ytan, ratan, dectan, icoo, + xcolumn, ycolumn, lngcolumn, latcolumn, tweak, + xref, yref, lngref, latref, xmin, xmax, ymin, ymax) + +int in #I the input file file descriptor +pointer im #I the input image pointer +double xtan, ytan #I the input x and y of the tangent point +double ratan, dectan #I the input ra and dec of the tangent point +pointer icoo #I the input coordinate system +int xcolumn, ycolumn #I the columns containing the x / y values +int lngcolumn, latcolumn #I the columns containing the lng / lat values +int tweak #I tweak flag +pointer xref, yref #I pointers to the input x / y values +pointer lngref, latref #I pointers to the input lng / lat values +double xmin, xmax #U the min and max x values +double ymin, ymax #U the min and max y values + +int nline, i, npts, bufsize, nfields, max_fields, nsig, offset +double lng1, lat1, lng2, lat2, x, y, z, sumx, sumy, sumz, r, pa, wterm[8] +pointer sp, inbuf, linebuf, field_pos +pointer mw, ct, coo +int getline(), li_get_numd(), sk_decim() +pointer mw_ctrand(), mw_sctran() + +int sk_stati() + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + + bufsize = CC_DEFBUFSIZE + call malloc (xref, bufsize, TY_DOUBLE) + call malloc (yref, bufsize, TY_DOUBLE) + call malloc (lngref, bufsize, TY_DOUBLE) + call malloc (latref, bufsize, TY_DOUBLE) + + # Check whether to adjust the reference value based on the + # current image WCS. + mw = NULL; ct = NULL; coo = NULL + if (tweak == 3 && im != NULL && !IS_INDEFD(xtan) && !IS_INDEFD(ytan) && + !IS_INDEFD(ratan) && !IS_INDEFD(dectan)) { + if (sk_decim (im, "logical", mw, coo) != ERR && mw != NULL) { + call sk_seti (coo, S_NLNGUNITS, SKY_DEGREES) + call sk_ultran (icoo, coo, ratan, dectan, lng1, lat1, 1) + call mw_gwtermd (mw, wterm[1], wterm[3], wterm[5], 2) + wterm[1] = xtan; wterm[2] = ytan + wterm[3] = lng1; wterm[4] = lat1 + call mw_swtermd (mw, wterm[1], wterm[3], wterm[5], 2) + ct = mw_sctran (mw, "logical", "world", 03B) + sumx = 0d0; sumy = 0d0; sumz = 0d0 + } else { + if (mw != NULL) + call mw_close (mw) + call sk_close (coo) + mw = NULL; coo = NULL + } + } + + npts = 0 + max_fields = MAX_FIELDS + for (nline = 1; getline (in, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (i = inbuf; IS_WHITE(Memc[i]); i = i + 1) + ; + + # Skip comment and blank lines. + if (Memc[i] == '#') + next + else if (Memc[i] == '\n' || Memc[i] == EOS) + next + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + # Decode the x coordinate. + if (xcolumn > nfields) + next + offset = Memi[field_pos+xcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[xref+npts], + nsig) == 0) + next + + # Decode the y coordinate. + if (ycolumn > nfields) + next + offset = Memi[field_pos+ycolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[yref+npts], + nsig) == 0) + next + + # Decode the ra / longitude coordinate. + if (lngcolumn > nfields) + next + offset = Memi[field_pos+lngcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[lngref+npts], + nsig) == 0) + next + + # Decode the dec / latitude coordinate. + if (latcolumn > nfields) + next + offset = Memi[field_pos+latcolumn-1] + if (li_get_numd (Memc[linebuf+offset-1], Memd[latref+npts], + nsig) == 0) + next + + # Accumulate cartisian shifts from image WCS coordinates. + if (ct != NULL) { + call mw_c2trand (ct, Memd[xref+npts], Memd[yref+npts], + lng1, lat1) + call sk_ultran (icoo, coo, Memd[lngref+npts], Memd[latref+npts], + lng2, lat2, 1) + lng1 = DDEGTORAD(lng1); lat1 = DDEGTORAD(lat1) + lng2 = DDEGTORAD(lng2); lat2 = DDEGTORAD(lat2) + x = sin (lat2) - sin(lat1) + y = cos (lat2) * sin (lng2) - cos (lat1) * sin (lng1) + z = cos (lat2) * cos (lng2) - cos (lat1) * cos (lng1) + sumx = sumx + x; sumy = sumy + y; sumz = sumz + z + } + + npts = npts + 1 + + if (npts >= bufsize) { + bufsize = bufsize + CC_DEFBUFSIZE + call realloc (xref, bufsize, TY_DOUBLE) + call realloc (yref, bufsize, TY_DOUBLE) + call realloc (lngref, bufsize, TY_DOUBLE) + call realloc (latref, bufsize, TY_DOUBLE) + } + } + + # Adjust the tangent point value. + if (npts > 0 && ct != NULL) { + sumx = sumx / npts; sumy = sumy / npts; sumz = sumz / npts + r = sqrt (sumx**2 + sumy**2 + sumz**2) / 2 + r = 2 * atan2 (r, sqrt(max(0d0,1d0-r))) + r = 3600 * DRADTODEG (r) + call eprintf ("Tangent point shift = %.2f\n") + call pargd (r) + + call sk_ultran (icoo, coo, ratan, dectan, lng1, lat1, 1) + lng2 = DDEGTORAD(lng1); lat2 = DDEGTORAD(lat1) + x = sin (lat2) + sumx + y = cos (lat2) * sin (lng2) + sumy + z = cos (lat2) * cos (lng2) + sumz + pa = atan2 (y, x) + if (pa < 0d0) + pa = pa + DTWOPI + if (pa >= DTWOPI) + pa = pa - DTWOPI + r = z + if (abs(r) > 0.99d0) { + if (r < 0d0) + r = DPI - asin (sqrt (x * x + y * y)) + else + r = asin (sqrt (x * x + y * y)) + } else + r = acos (r) + x = sin (r) * cos (pa) + y = sin (r) * sin (pa) + z = cos (r) + lng2 = atan2 (y, z) + if (lng2 < 0d0) + lng2 = lng2 + DTWOPI + if (lng2 >= DTWOPI) + lng2 = lng2 - DTWOPI + lat2 = x + if (abs (lat2) > 0.99d0) { + if (lat2 < 0d0) + lat2 = -acos (sqrt (y * y + z * z)) + else + lat2 = acos (sqrt (y * y + z * z)) + } else + lat2 = asin (lat2) + lng2 = DRADTODEG (lng2); lat2 = DRADTODEG (lat2) + call sk_ultran (coo, icoo, lng2, lat2, ratan, dectan, 1) + } + + # Finish up. + + if (npts <= 0) { + call mfree (xref, TY_DOUBLE) + call mfree (yref, TY_DOUBLE) + call mfree (lngref, TY_DOUBLE) + call mfree (latref, TY_DOUBLE) + + call fstats (in, F_FILENAME, Memc[linebuf], SZ_LINE) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[linebuf]) + } else if (npts < bufsize) { + call realloc (xref, npts, TY_DOUBLE) + call realloc (yref, npts, TY_DOUBLE) + call realloc (lngref, npts, TY_DOUBLE) + call realloc (latref, npts, TY_DOUBLE) + } + + if (ct != NULL) + call mw_ctfree (ct) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + call sk_close (coo) + call sfree (sp) + + return (npts) +end + + +# CC_REFPT -- Compute the coordinates of the reference point by averaging +# the celestial coordinates. + + +procedure cc_refpt (coo, lngref, latref, npts, lngmean, latmean) + +pointer coo #I the input coordinate system descriptor +double lngref[ARB] #I the input longitude coordinates +double latref[ARB] #I the input latitude coordinates +int npts #I the number of input coordinates +double lngmean #O the output mean longitude +double latmean #O the output mean latitude + +double sumx, sumy, sumz, sumdx, sumdy, sumdz +double tlng, tlat +double x, y, z, tr, tpa +int i +int sk_stati() + +begin + sumx = 0.0d0; sumy = 0.0d0; sumz = 0.0d0 + sumdx = 0.0d0; sumdy = 0.0d0; sumdz = 0.0d0 + + # Loop over the data points. + do i = 1, npts { + + # Convert to radians. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_HOURS: + tlng = DDEGTORAD (15.0d0 * lngref[i]) + case SKY_DEGREES: + tlng = DDEGTORAD (lngref[i]) + case SKY_RADIANS: + tlng = lngref[i] + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_HOURS: + tlat = DDEGTORAD (15.0d0 * latref[i]) + case SKY_DEGREES: + tlat = DDEGTORAD (latref[i]) + case SKY_RADIANS: + tlat = latref[i] + } + + x = sin (tlat) + y = cos (tlat) * sin (tlng) + z = cos (tlat) * cos (tlng) + + sumx = sumx + x + sumy = sumy + y + sumz = sumz + z + } + + # Compute the average vector components. + sumx = sumx / npts + sumy = sumy / npts + sumz = sumz / npts + + # Now compute the average distance and position angle. + tpa = atan2 (sumy, sumx) + if (tpa < 0.0d0) + tpa = tpa + DTWOPI + if (tpa >= DTWOPI) + tpa = tpa - DTWOPI + tr = sumz + if (abs(tr) > 0.99d0) { + if (tr < 0.0d0) + tr = DPI - asin (sqrt (sumx * sumx + sumy * sumy)) + else + tr = asin (sqrt (sumx * sumx + sumy * sumy)) + } else + tr = acos (tr) + + # Solve for the average longitude and latitude. + sumx = sin (tr) * cos (tpa) + sumy = sin (tr) * sin (tpa) + sumz = cos (tr) + lngmean = atan2 (sumy, sumz) + if (lngmean < 0.0d0) + lngmean = lngmean + DTWOPI + if (lngmean >= DTWOPI) + lngmean = lngmean - DTWOPI + latmean = sumx + if (abs (latmean) > 0.99d0) { + if (latmean < 0.0d0) + latmean = -acos (sqrt(sumy ** 2 + sumz ** 2)) + else + latmean = acos (sqrt(sumy ** 2 + sumz ** 2)) + } else + latmean = asin (latmean) + + # Convert back to appropriate units. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_HOURS: + lngmean = DRADTODEG (lngmean) / 15.0d0 + case SKY_DEGREES: + lngmean = DRADTODEG (lngmean) + case SKY_RADIANS: + ; + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_HOURS: + latmean = DRADTODEG (latmean) / 15.0d0 + case SKY_DEGREES: + latmean = DRADTODEG (latmean) + case SKY_RADIANS: + ; + } +end + + +# CC_EVAL -- Compute the fitted standard coordinates. + +procedure cc_eval (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +double xref[ARB] #I the x reference coordinates +double yref[ARB] #I the y reference coordinates +double xi[ARB] #O the fitted xi coordinates +double eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_DOUBLE) + + call dgsvector (sx1, xref, yref, xi, npts) + if (sx2 != NULL) { + call dgsvector (sx2, xref, yref, Memd[temp], npts) + call aaddd (Memd[temp], xi, xi, npts) + } + call dgsvector (sy1, xref, yref, eta, npts) + if (sy2 != NULL) { + call dgsvector (sy2, xref, yref, Memd[temp], npts) + call aaddd (Memd[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# CC_RMS -- Compute the rms of the fit in arcseconds. + +procedure cc_rms (fit, xi, eta, xifit, etafit, wts, npts, xirms, etarms) + +pointer fit #I pointer to the fit structure +double xi[ARB] #I the input xi coordinates +double eta[ARB] #I the input eta coordinates +double xifit[ARB] #I the fitted chi coordinates +double etafit[ARB] #I the fitted eta coordinates +double wts[ARB] #I the input weights array +int npts #I the number of points +double xirms #O the output xi rms +double etarms #O the output eta rms + +int i, index, ngood +pointer sp, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_DOUBLE) + + # Compute the weights. + call amovd (wts, Memd[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > 0.0d0) + Memd[twts+index-1] = 0.0d0 + } + + # Accumulate the squares. + xirms = 0.0d0 + etarms = 0.0d0 + do i = 1, npts { + xirms = xirms + Memd[twts+i-1] * (xi[i] - xifit[i]) ** 2 + etarms = etarms + Memd[twts+i-1] * (eta[i] - etafit[i]) ** 2 + } + + # Compute the rms. + #ngood = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + ngood = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + if (ngood > 1) { + xirms = sqrt (xirms / (ngood - 1)) + etarms = sqrt (etarms / (ngood - 1)) + } else { + xirms = 0.0d0 + etarms = 0.0d0 + } + xirms = xirms + etarms = etarms + + call sfree (sp) +end + + +# CC_SHOW -- Print the coodinate mapping parameters. + +procedure cc_show (fd, coo, projection, lngref, latref, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the coordinates of the reference point +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +double xshift, yshift, a, b, c, d, denom +double xpix, ypix, xscale, yscale, xrot, yrot +pointer sp, str, keyword, value +bool fp_equald() +int sk_stati() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the position of the reference pixel from the geometric + # parameters. + denom = a * d - c * b + if (denom == 0.0d0) + xpix = INDEFD + else + xpix = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypix = INDEFD + else + ypix = (c * xshift - a * yshift) / denom + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + call fprintf (fd, " Sky projection geometry: %s\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + call fprintf (fd, "# Sky projection geometry: %s\n") + } + if (projection[1] == EOS) + call pargstr ("lin") + else { + call sscan (projection) + call gargwrd (Memc[str], SZ_LINE) + call pargstr (Memc[str]) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + if (comment == NO) { + call fprintf (fd, " Projection parameter %s: %s\n") + } else { + call fprintf (fd, "# Projection parameter %s: %s\n") + } + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + + } + + # Output the reference point. + if (comment == NO) { + call sprintf (Memc[str], SZ_LINE, + " Reference point: %s %s (%s %s)\n") + } else { + call sprintf (Memc[str], SZ_LINE, + "# Reference point: %s %s (%s %s)\n") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + if (comment == NO) { + call printf (Memc[str]) + call pargd (lngref) + call pargd (latref) + } else { + call fprintf (fd, Memc[str]) + call pargd (lngref) + call pargd (latref) + } + + if (comment == NO) { + call fprintf (fd, + " Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xpix) + call pargd (ypix) + } else { + call fprintf (fd, + "# Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xpix) + call pargd (ypix) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + } + + # Output the rotation factors. + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } + + call sfree (sp) +end + + +# CC_OUT -- Write the output database file record. + +procedure cc_out (fit, coo, out, sx1, sy1, sx2, sy2, lxrms, lyrms) + +pointer fit #I pointer to fitting structure +pointer coo #I pointer to the coordinate system structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces +double lxrms, lyrms #I the input wcs x and y rms + +double xshift, yshift, a, b, c, d, denom, xrms, yrms +double xpixref, ypixref, xscale, yscale, xrot, yrot +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff, keyword, value +bool fp_equald() +int dgsgeti(), rg_wrdstr(), sk_stati() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + # Compute the rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + denom = a * d - c * b + if (denom == 0.0d0) + xpixref = INDEFD + else + xpixref = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + ypixref = INDEFD + else + ypixref = (c * xshift - a * yshift) / denom + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG(atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG(atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print out some information about the data. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\tlngmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tlatmean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print out information about the tangent point. + if (rg_wrdstr(sk_stati(coo, S_PIXTYPE), Memc[str], SZ_FNAME, + PIXTYPE_LIST) <= 0) + call strcpy ("logical", Memc[str], SZ_FNAME) + call dtput (out, "\tpixsystem\t%s\n") + call pargstr (Memc[str]) + call sk_stats (coo, S_COOSYSTEM, Memc[str], SZ_FNAME) + call dtput (out, "\tcoosystem\t%g\n") + call pargstr (Memc[str]) + + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + call strcpy ("tan", Memc[str], SZ_FNAME) + call dtput (out, "\tprojection\t%s\n") + call pargstr (Memc[str]) + call sscan (GM_PROJSTR(fit)) + call gargwrd (Memc[str], SZ_FNAME) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + call dtput (out, "\t%s\t\t%s\n") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + + call dtput (out, "\tlngref\t\t%g\n") + call pargd (GM_XREFPT(fit)) + call dtput (out, "\tlatref\t\t%g\n") + call pargd (GM_YREFPT(fit)) + if (rg_wrdstr (sk_stati(coo, S_NLNGUNITS), Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST) <= 0) + ; + call dtput (out, "\tlngunits\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (sk_stati(coo, S_NLATUNITS), Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST) <= 0) + ; + call dtput (out, "\tlatunits\t%s\n") + call pargstr (Memc[str]) + call dtput (out, "\txpixref\t\t%g\n") + call pargd (xpixref) + call dtput (out, "\typixref\t\t%g\n") + call pargd (ypixref) + + # Print out information about the fit. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + call dtput (out, "\txishift\t\t%g\n") + call pargd (xshift) + call dtput (out, "\tetashift\t%g\n") + call pargd (yshift) + call dtput (out, "\txmag\t\t%g\n") + call pargd (xscale) + call dtput (out, "\tymag\t\t%g\n") + call pargd (yscale) + call dtput (out, "\txrotation\t%g\n") + call pargd (xrot) + call dtput (out, "\tyrotation\t%g\n") + call pargd (yrot) + + # Output the rms of the fit. + call dtput (out, "\twcsxirms\t%g\n") + call pargd (lxrms) + call dtput (out, "\twcsetarms\t%g\n") + call pargd (lyrms) + call dtput (out, "\txirms\t\t%g\n") + call pargd (xrms) + call dtput (out, "\tetarms\t\t%g\n") + call pargd (yrms) + + # Allocate memory for linear coefficients. + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Encode the linear coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Output the linear coefficients. + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + # Free the linear coefficient memory. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else + ncoeff = dgsgeti (sx2, GSNSAVE) + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else + ncoeff = max (dgsgeti (sy2, GSNSAVE), ncoeff) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Encode the coefficients. + call dgssave (sx2, Memd[xcoeff]) + call dgssave (sy2, Memd[ycoeff]) + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + call sfree (sp) +end + + +# CC_PLIST -- List the coordinates and the residuals. + +procedure cc_plist (fd, fit, coo, xref, yref, lngref, latref, lngfit, latfit, + wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +pointer coo #I pointer to the coordinate structure +double xref[ARB] #I the input x coordinates +double yref[ARB] #I the input y coordinates +double lngref[ARB] #I the input ra / longitude coordinates +double latref[ARB] #I the input dec / latitude coordinates +double lngfit[ARB] #I the fitted ra / longitude coordinates +double latfit[ARB] #I the fitted dec / latitude coordinates +double wts[ARB] #I the weights array +int npts #I the number of data points + +double diflng, diflat +int i, index +pointer sp, fmtstr, lngunits, latunits, twts +int sk_stati() + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (lngunits, SZ_FNAME, TY_CHAR) + call salloc (latunits, SZ_FNAME, TY_CHAR) + call salloc (twts, npts, TY_DOUBLE) + + # Get the unit strings. + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call strcpy ("hours", Memc[lngunits], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("degrees", Memc[lngunits], SZ_FNAME) + default: + call strcpy ("radians", Memc[lngunits], SZ_FNAME) + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call strcpy ("hours", Memc[latunits], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("degrees", Memc[latunits], SZ_FNAME) + default: + call strcpy ("radians", Memc[latunits], SZ_FNAME) + } + + # Compute the weights. + call amovd (wts, Memd[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > 0.0d0) + Memd[twts+index-1] = 0.0d0 + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (pixels)\n") + call fprintf (fd, "# Column 2: Y (pixels)\n") + call fprintf (fd, "# Column 3: Ra / Longitude (%s)\n") + call pargstr (Memc[lngunits]) + call fprintf (fd, "# Column 4: Dec / Latitude (%s)\n") + call pargstr (Memc[latunits]) + call fprintf (fd, "# Column 5: Fitted Ra / Longitude (%s)\n") + call pargstr (Memc[lngunits]) + call fprintf (fd, "# Column 6: Fitted Dec / Latitude (%s)\n") + call pargstr (Memc[latunits]) + call fprintf (fd, + "# Column 7: Residual Ra / Longitude (arcseconds)\n") + call fprintf (fd, + "# Column 8: Residual Dec / Latitude (arcseconds)\n\n") + + # Create format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%10.3f") + call pargstr ("%10.3f") + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_HOURS: + call pargstr ("%12.3h") + case SKY_DEGREES: + call pargstr ("%12.2h") + default: + call pargstr ("%12.7g") + } + call pargstr ("%6.3f") + call pargstr ("%6.3f") + + do i = 1, npts { + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + diflng = (lngref[i] - lngfit[i]) * 3600.0d0 + case SKY_HOURS: + diflng = 15.0d0 * (lngref[i] - lngfit[i]) * 3600.0d0 * + cos (DEGTORAD(latref[i])) + case SKY_RADIANS: + diflng = RADTODEG ((lngref[i] - lngfit[i])) * 3600.0d0 + default: + diflng = lngref[i] - lngfit[i] + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + diflat = (latref[i] - latfit[i]) * 3600.0d0 + case SKY_HOURS: + diflat = 15.0d0 * (latref[i] - latfit[i]) * 3600.0d0 + case SKY_RADIANS: + diflat = RADTODEG ((latref[i] - latfit[i])) * 3600.0d0 + default: + diflat = latref[i] - latfit[i] + } + call fprintf (fd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (lngref[i]) + call pargd (latref[i]) + if (Memd[twts+i-1] > 0.0d0) { + call pargd (lngfit[i]) + call pargd (latfit[i]) + call pargd (diflng) + call pargd (diflat) + } else { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } + } + + call fprintf (fd, "\n") + + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_ccsetwcs.x b/pkg/images/imcoords/src/t_ccsetwcs.x new file mode 100644 index 00000000..85c0c0ff --- /dev/null +++ b/pkg/images/imcoords/src/t_ccsetwcs.x @@ -0,0 +1,751 @@ +include +include +include +include + +# Define the possible pixel types + +define CC_PIXTYPESTR "|logical|physical|" +define CC_LOGICAL 1 +define CC_PHYSICAL 2 + + +# T_CCSETWCS -- Create a wcs and write it to the image header. The wcs may +# be read from a database file written by CCMAP or it may be input by the +# user. + +procedure t_ccsetwcs () + +bool transpose, verbose, update +double xref, yref, xscale, yscale, xrot, yrot, lngref, latref +double txref, tyref, txscale, tyscale, txrot, tyrot, tlngref, tlatref +int imlist, reclist, lngunits, latunits, coostat, recstat, proj, pixsys, pfd +pointer sp, image, database, record, insystem, projstr, str +pointer dt, im, coo, tcoo, mw, sx1, sy1, sx2, sy2 +bool clgetb() +double clgetd() +int imtopenp(), clgwrd(), sk_decwcs(), sk_stati(), imtlen() +int imtgetim(), cc_dtwcs(), strdic(), cc_rdproj(), open() +pointer dtmap(), immap() +errchk open() + +begin + # Allocate some working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + imlist = imtopenp ("images") + call clgstr ("database", Memc[database], SZ_FNAME) + + # Fetch the celestial coordinate system parameters. + if (Memc[database] == EOS) { + dt = NULL + reclist = NULL + xref = clgetd ("xref") + yref = clgetd ("yref") + xscale = clgetd ("xmag") + yscale = clgetd ("ymag") + xrot = clgetd ("xrotation") + yrot = clgetd ("yrotation") + lngref = clgetd ("lngref") + latref = clgetd ("latref") + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + latunits = 0 + call clgstr ("coosystem", Memc[insystem], SZ_FNAME) + coostat = sk_decwcs (Memc[insystem], mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + call eprintf ("Error decoding the coordinate system %s\n") + call pargstr (Memc[insystem]) + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + call imtclose (imlist) + call sfree (sp) + return + } + if (lngunits <= 0) + lngunits = sk_stati (coo, S_NLNGUNITS) + call sk_seti (coo, S_NLNGUNITS, lngunits) + if (latunits <= 0) + latunits = sk_stati (coo, S_NLATUNITS) + call sk_seti (coo, S_NLATUNITS, latunits) + + call clgstr ("projection", Memc[projstr], SZ_LINE) + iferr { + pfd = open (Memc[projstr], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projstr], Memc[projstr], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projstr], SZ_LINE) + call close (pfd) + } + + iferr (pixsys = clgwrd ("pixsystem", Memc[str], SZ_FNAME, + CC_PIXTYPESTR)) + pixsys = PIXTYPE_LOGICAL + else if (pixsys == CC_PHYSICAL) + pixsys = PIXTYPE_PHYSICAL + else + pixsys = PIXTYPE_LOGICAL + call sk_seti (coo, S_PIXTYPE, pixsys) + } else { + dt = dtmap (Memc[database], READ_ONLY) + reclist = imtopenp ("solutions") + if ((imtlen (reclist) > 1) && (imtlen (imlist) != + imtlen (reclist))) { + call eprintf ( + " The image and record list lengths are different\n") + call imtclose (reclist) + call dtunmap (dt) + call imtclose (imlist) + call sfree (sp) + return + } + coo = NULL + } + + transpose = clgetb ("transpose") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + if (update) + im = immap (Memc[image], READ_WRITE, 0) + else + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) != 2) { + call printf ("Skipping non 2D image %s\n") + call pargstr (Memc[image]) + call imunmap (im) + next + } + + if (dt == NULL) { + + if (verbose) { + call printf ("Image: %s\n") + call pargstr (Memc[image]) + } + + # Compute the linear transformation parameters. + if (IS_INDEFD(lngref)) + tlngref = 0.0d0 + else + tlngref = lngref + if (IS_INDEFD(latref)) + tlatref = 0.0d0 + else + tlatref = latref + if (IS_INDEFD(xref)) + txref = (1.0d0 + IM_LEN(im,1)) / 2.0 + else + txref = xref + if (IS_INDEFD(yref)) + tyref = (1.0d0 + IM_LEN(im,2)) / 2.0 + else + tyref = yref + if (IS_INDEFD(xscale)) + txscale = 1.0d0 + else + txscale = xscale + if (IS_INDEFD(yscale)) + tyscale = 1.0d0 + else + tyscale = yscale + if (IS_INDEFD(xrot)) + txrot = 0.0d0 + else + txrot = xrot + if (IS_INDEFD(yrot)) + tyrot = 0.0d0 + else + tyrot = yrot + + if (verbose) + call cc_usershow (coo, Memc[projstr], tlngref, tlatref, + txref, tyref, txscale, tyscale, txrot, tyrot, + transpose) + + if (update) { + call cc_userwcs (im, coo, Memc[projstr], tlngref, tlatref, + txref, tyref, txscale, tyscale, txrot, tyrot, + transpose) + if (verbose) + call printf ("Updating image header wcs\n") + } + + } else { + if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + #call strcpy (Memc[image], Memc[record], SZ_FNAME) + ; + if (verbose) { + call printf ("Image: %s Database: %s Solution: %d\n") + call pargstr (Memc[image]) + call pargstr (Memc[database]) + call pargstr (Memc[record]) + } + sx1 = NULL; sx2 = NULL + sy1 = NULL; sy2 = NULL + tcoo = NULL + recstat = cc_dtwcs (dt, Memc[record], tcoo, Memc[projstr], + tlngref, tlatref, sx1, sy1, sx2, sy2, txref, tyref, txscale, + tyscale, txrot, tyrot) + if (recstat == ERR) { + call printf (" Cannot find or decode ") + call printf ("record %s in database file %s\n") + call pargstr (Memc[record]) + call pargstr (Memc[database]) + } else { + call sscan (Memc[projstr]) + call gargwrd (Memc[str], SZ_FNAME) + proj = strdic (Memc[str], Memc[str], SZ_FNAME, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projstr] = EOS + if (verbose) + call cc_usershow (tcoo, Memc[projstr], tlngref, + tlatref, txref, tyref, txscale, tyscale, txrot, + tyrot, transpose) + if (update) { + call cc_nwcsim (im, tcoo, Memc[projstr], tlngref, + tlatref, sx1, sy1, sx2, sy2, transpose) + if (verbose) + call printf ("Updating image header wcs\n") + } + } + if (tcoo != NULL) + #call mfree (tcoo, TY_STRUCT) + call sk_close (tcoo) + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + } + + call imunmap (im) + } + + # Close up memory. + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + if (dt != NULL) + call dtunmap (dt) + if (reclist != NULL) + call imtclose (reclist) + call imtclose (imlist) + + call sfree (sp) +end + + +define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] + +# CC_USERWCS -- Compute the image wcs from the user parameters. + +procedure cc_userwcs (im, coo, projection, lngref, latref, xref, yref, + xscale, yscale, xrot, yrot, transpose) + +pointer im #I pointer to the input image +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +double tlngref, tlatref +int l, i, ndim, naxes, axmap, wtype, ax1, ax2, szatstr +pointer mw, sp, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval +pointer projstr, projpars, wpars, mwnew, atstr +int mw_stati(), sk_stati(), strdic(), strlen(), itoc() +pointer mw_openim(), mw_open() +errchk mw_newsystem(), mw_gwattrs() + +begin + mw = mw_openim (im) + ndim = mw_stati (mw, MW_NPHYSDIM) + # Allocate working memory for the vectors and matrices. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + call salloc (nr, ndim, TY_DOUBLE) + call salloc (ncd, ndim * ndim, TY_DOUBLE) + call salloc (axes, IM_MAXDIM, TY_INT) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + + # Open the new wcs + mwnew = mw_open (NULL, ndim) + call mw_gsystem (mw, Memc[projstr], SZ_FNAME) + iferr { + call mw_newsystem (mw, "image", ndim) + } then { + call mw_newsystem (mwnew, Memc[projstr], ndim) + } else { + call mw_newsystem (mwnew, "image", ndim) + } + + # Set the LTERM. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwnew, Memd[ltm], Memd[ltv], ndim) + + # Store the old axis map for later use. + call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) + + # Get the 2 logical axes. + call mw_gaxlist (mw, 03B, Memi[axes], naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + ax1 = Memi[axes] + ax2 = Memi[axes+1] + + # Set the axes and projection type. + if (projection[1] == EOS) { + call mw_swtype (mwnew, Memi[axes], ndim, "linear", "") + } else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mwnew, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + # Copy in the atrributes of the other axes. + szatstr = SZ_LINE + call malloc (atstr, szatstr, TY_CHAR) + do l = 1, ndim { + if (l == ax1 || l == ax2) + next + iferr { + call mw_gwattrs (mw, l, "wtype", Memc[projpars], SZ_LINE) + } then { + call mw_swtype (mwnew, l, 1, "linear", "") + } else { + call mw_swtype (mwnew, l, 1, Memc[projpars], "") + } + for (i = 1; ; i = i + 1) { + if (itoc (i, Memc[projpars], SZ_LINE) <= 0) + Memc[atstr] = EOS + repeat { + iferr (call mw_gwattrs (mw, l, Memc[projpars], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen (Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwnew, 1, Memc[projpars], Memc[atstr]) + } + } + call mfree (atstr, TY_CHAR) + + # Compute the referemce point world coordinates. + switch (sk_stati(coo, S_NLNGUNITS)) { + case SKY_DEGREES: + tlngref = lngref + case SKY_RADIANS: + tlngref = RADTODEG(lngref) + case SKY_HOURS: + tlngref = 15.0d0 * lngref + default: + tlngref = lngref + } + switch (sk_stati(coo, S_NLATUNITS)) { + case SKY_DEGREES: + tlatref = latref + case SKY_RADIANS: + tlatref = RADTODEG(latref) + case SKY_HOURS: + tlatref = 15.0d0 * latref + default: + tlatref = latref + } + + if (! transpose) { + Memd[w+ax1-1] = tlngref + Memd[w+ax2-1] = tlatref + } else { + Memd[w+ax2-1] = tlngref + Memd[w+ax1-1] = tlatref + } + + # Compute the reference point pixel coordinates. + Memd[nr+ax1-1] = xref + Memd[nr+ax2-1] = yref + + # Compute the new CD matrix. + if (! transpose) { + NEWCD(ax1,ax1) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax1) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(ax1,ax2) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax2) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + } else { + NEWCD(ax1,ax1) = xscale * sin (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax1) = yscale * cos (DEGTORAD(yrot)) / 3600.0d0 + NEWCD(ax1,ax2) = xscale * cos (DEGTORAD(xrot)) / 3600.0d0 + NEWCD(ax2,ax2) = -yscale * sin (DEGTORAD(yrot)) / 3600.0d0 + } + + # Reset the axis map. + call mw_seti (mw, MW_USEAXMAP, axmap) + + # Recompute and store the new wcs if update is enabled. + call mw_saxmap (mwnew, Memi[axno], Memi[axval], ndim) + if (sk_stati (coo, S_PIXTYPE) == PIXTYPE_PHYSICAL) { + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[ncd], ndim) + } else { + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) + } + # Save the fit. + if (! transpose) { + call sk_seti (coo, S_PLNGAX, ax1) + call sk_seti (coo, S_PLATAX, ax2) + } else { + call sk_seti (coo, S_PLNGAX, ax2) + call sk_seti (coo, S_PLATAX, ax1) + } + call sk_saveim (coo, mwnew, im) + call mw_saveim (mwnew, im) + call mw_close (mwnew) + call mw_close (mw) + + # Force the CDELT keywords to update. This will be unecessary when + # mwcs is updated to deal with non-quoted and / or non left-justified + # CTYPE keywords.. + wtype = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) + if (wtype > 0) + call sk_seti (coo, S_WTYPE, wtype) + call sk_ctypeim (coo, im) + + # Reset the fit. This will be unecessary when wcs is updated to deal + # with non-quoted and / or non left-justified CTYPE keywords. + call sk_seti (coo, S_WTYPE, 0) + call sk_seti (coo, S_PLNGAX, 0) + call sk_seti (coo, S_PLATAX, 0) + + call sfree (sp) +end + + +# CC_USERSHOW -- Print the image wcs parameters in user friendly format. + +procedure cc_usershow (coo, projection, lngref, latref, xref, yref, xscale, + yscale, xrot, yrot, transpose) + +pointer coo #I pointer to the coordinate structure +char projection[ARB] #I the sky projection geometry +double lngref, latref #I the world coordinates of the reference point +double xref, yref #I the reference point in pixels +double xscale, yscale #I the x and y scale in arcsec / pixel +double xrot, yrot #I the x and y axis rotation angles in degrees +bool transpose #I transpose the wcs + +pointer sp, str, keyword, value +int sk_stati() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (keyword, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + + call printf ("Coordinate mapping parameters\n") + call printf (" Sky projection geometry: %s\n") + if (projection[1] == EOS) + call pargstr ("lin") + else { + call sscan (projection) + call gargwrd (Memc[str], SZ_LINE) + call pargstr (Memc[str]) + repeat { + call gargwrd (Memc[keyword], SZ_FNAME) + if (Memc[keyword] == EOS) + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] != '=') + break + call gargwrd (Memc[value], SZ_FNAME) + if (Memc[value] == EOS) + break + call printf (" Projection parameter %s: %s\n") + call pargstr (Memc[keyword]) + call pargstr (Memc[value]) + } + } + + # Output the reference point. + call sprintf (Memc[str], SZ_LINE, + " Reference point: %s %s (%s %s)\n") + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("%0.2h") + case SKY_RADIANS: + call pargstr ("%0.7g") + case SKY_HOURS: + call pargstr ("%0.3h") + } + switch (sk_stati (coo, S_NLNGUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + switch (sk_stati (coo, S_NLATUNITS)) { + case SKY_DEGREES: + call pargstr ("degrees") + case SKY_RADIANS: + call pargstr ("radians") + case SKY_HOURS: + call pargstr ("hours") + } + call printf (Memc[str]) + call pargd (lngref) + call pargd (latref) + + # Output the logical axes. + if (sk_stati (coo, S_CTYPE) == CTYPE_EQUATORIAL) + call printf (" Ra/Dec logical image axes: %d %d\n") + else + call printf (" Long/Lat logical image axes: %d %d\n") + if (! transpose) { + call pargi (1) + call pargi (2) + } else { + call pargi (2) + call pargi (1) + } + + # Output the reference point in pixels. + call printf (" Reference point: %0.3f %0.3f (pixels pixels)\n") + call pargd (xref) + call pargd (yref) + + # Output the scale factors. + call printf ( + " X and Y scale: %0.3f %0.3f (arcsec/pixel arcsec/pixel)\n") + call pargd (xscale) + call pargd (yscale) + + # Output the rotation angles. + call printf ( + " X and Y coordinate rotation: %0.3f %0.3f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + + call sfree (sp) +end + + +# CC_DTWCS -- Read the wcs from the database records written by CCMAP. + +int procedure cc_dtwcs (dt, record, coo, projection, lngref, latref, sx1, sy1, + sx2, sy2, xref, yref, xscale, yscale, xrot, yrot) + +pointer dt #I pointer to the database +char record[ARB] #I the database records to be read +pointer coo #O pointer to the coordinate structure +char projection[ARB] #O the sky projection geometry +double lngref, latref #O the reference point world coordinates +pointer sx1, sy1 #O pointer to the linear x and y fits +pointer sx2, sy2 #O pointer to the distortion x and y fits +double xref, yref #O the reference point in pixels +double xscale, yscale #O the x and y scale factors +double xrot, yrot #O the x and y axis rotation angles + +int i, op, ncoeff, junk, rec, coostat, lngunits, latunits, pixsys +double xshift, yshift, a, b, c, d, denom +pointer sp, xcoeff, ycoeff, nxcoeff, nycoeff, mw, projpar, projvalue +bool fp_equald() +double dtgetd() +int dtlocate(), dtgeti(), dtscan(), sk_decwcs(), strdic(), strlen() +int gstrcpy() +errchk dtgstr(), dtgetd(), dtgeti(), dgsrestore() + +begin + # Locate the appropriate records. + iferr (rec = dtlocate (dt, record)) + return (ERR) + + # Open the coordinate structure. + iferr (call dtgstr (dt, rec, "coosystem", projection, SZ_FNAME)) + return (ERR) + coostat = sk_decwcs (projection, mw, coo, NULL) + if (coostat == ERR || mw != NULL) { + if (mw != NULL) + call mw_close (mw) + projection[1] = EOS + return (ERR) + } + + # Get the pixel coordinate system. + iferr (call dtgstr (dt, rec, "pixsystem", projection, SZ_FNAME)) { + pixsys = PIXTYPE_LOGICAL + } else { + pixsys = strdic (projection, projection, SZ_FNAME, PIXTYPE_LIST) + if (pixsys != PIXTYPE_PHYSICAL) + pixsys = PIXTYPE_LOGICAL + } + call sk_seti (coo, S_PIXTYPE, pixsys) + + + # Get the reference point units. + iferr (call dtgstr (dt, rec, "lngunits", projection, SZ_FNAME)) + return (ERR) + lngunits = strdic (projection, projection, SZ_FNAME, SKY_LNG_UNITLIST) + if (lngunits > 0) + call sk_seti (coo, S_NLNGUNITS, lngunits) + iferr (call dtgstr (dt, rec, "latunits", projection, SZ_FNAME)) + return (ERR) + latunits = strdic (projection, projection, SZ_FNAME, SKY_LAT_UNITLIST) + if (latunits > 0) + call sk_seti (coo, S_NLATUNITS, latunits) + + # Get the reference point. + iferr (call dtgstr (dt, rec, "projection", projection, SZ_FNAME)) + return (ERR) + iferr (lngref = dtgetd (dt, rec, "lngref")) + return (ERR) + iferr (latref = dtgetd (dt, rec, "latref")) + return (ERR) + + # Read in the coefficients. + iferr (ncoeff = dtgeti (dt, rec, "surface1")) + return (ERR) + call smark (sp) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore the linear part of the fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + # Get and restore the distortion part of the fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0) { + call salloc (nxcoeff, ncoeff, TY_DOUBLE) + call salloc (nycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargd (Memd[nxcoeff+i-1]) + call gargd (Memd[nycoeff+i-1]) + } + iferr { + call dgsrestore (sx2, Memd[nxcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Memd[nycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + } else { + sx2 = NULL + sy2 = NULL + } + # Compute the coefficients. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + # Compute the reference point. + denom = a * d - c * b + if (denom == 0.0d0) + xref = INDEFD + else + xref = (b * yshift - d * xshift) / denom + if (denom == 0.0d0) + yref = INDEFD + else + yref = (c * xshift - a * yshift) / denom + + # Compute the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Compute the rotation angles. + if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) + xrot = 0.0d0 + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < 0.0d0) + xrot = xrot + 360.0d0 + if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) + yrot = 0.0d0 + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < 0.0d0) + yrot = yrot + 360.0d0 + + # Read in up to 10 projection parameters. + call salloc (projpar, SZ_FNAME, TY_CHAR) + call salloc (projvalue, SZ_FNAME, TY_CHAR) + op = strlen (projection) + 1 + do i = 0, 9 { + call sprintf (Memc[projpar], SZ_FNAME, "projp%d") + call pargi (i) + iferr (call dtgstr (dt, rec, Memc[projpar], Memc[projvalue], + SZ_FNAME)) + next + op = op + gstrcpy (" ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projpar], projection[op], + SZ_LINE - op + 1) + op = op + gstrcpy (" = ", projection[op], SZ_LINE - op + 1) + op = op + gstrcpy (Memc[projvalue], projection[op], + SZ_LINE - op + 1) + } + + call sfree (sp) + + return (OK) +end diff --git a/pkg/images/imcoords/src/t_ccstd.x b/pkg/images/imcoords/src/t_ccstd.x new file mode 100644 index 00000000..d9ce3a6b --- /dev/null +++ b/pkg/images/imcoords/src/t_ccstd.x @@ -0,0 +1,468 @@ +include +include +include +include + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# T_CCSTD -- Transform a list of x and y and RA and DEC coordinates to +# their polar coordinate equivalents, after appying an optional linear +# transformation to the x and y side + +procedure t_ccstd() + +bool forward, polar +int inlist, outlist, reclist, infd, outfd +int xcolumn, ycolumn, lngcolumn, latcolumn, lngunits, latunits +int geometry, min_sigdigits +pointer sp, infile, outfile, record, str, dt, sx1, sy1, sx2, sy2, coo, mw +pointer xformat, yformat, lngformat, latformat +bool clgetb(), streq() +int fntopnb(), imtopenp(), fntlenb(), imtlen(), fntgfnb(), imtgetim() +int open(), clgwrd(), clgeti() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (lngformat, SZ_FNAME, TY_CHAR) + call salloc (latformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the input and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDIN", Memc[str], SZ_FNAME) + inlist = fntopnb(Memc[str], NO) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + call clgstr ("database", Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + dt = dtmap (Memc[str], READ_ONLY) + reclist = imtopenp ("solutions") + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + } else { + dt = NULL + reclist = NULL + geometry = 0 + } + forward = clgetb ("forward") + polar = clgetb ("polar") + + # Test the input and out file and record lists for validity. + if (fntlenb(inlist) <= 0) + call error (0, "The input file list is empty") + if (fntlenb(outlist) <= 0) + call error (0, "The output file list is empty") + if (fntlenb(outlist) > 1 && fntlenb(outlist) != fntlenb(inlist)) + call error (0, + "Input and output file lists are not the same length") + if (dt != NULL && reclist != NULL) { + if (imtlen (reclist) > 1 && imtlen (reclist) != fntlenb (inlist)) + call error (0, + "Input file and record lists are not the same length.") + } + + # Get the input file format parameters. + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_LINE, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_LINE, + SKY_LAT_UNITLIST)) + latunits = 0 + + # Get the output file format parameters. + call clgstr ("lngformat", Memc[lngformat], SZ_FNAME) + call clgstr ("latformat", Memc[latformat], SZ_FNAME) + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the output file name. + if (fntgfnb (outlist, Memc[outfile], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[outfile], SZ_FNAME) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + + # Get the record name. + if (reclist == NULL) + Memc[record] = EOS + else if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + Memc[record] = EOS + + # Call procedure to get parameters and fill structure. + coo = NULL; sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call cc_init_std (dt, Memc[record], geometry, lngunits, + latunits, sx1, sy1, sx2, sy2, mw, coo) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[infile], SZ_FNAME) != EOF) { + + infd = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call cc_transform_std (infd, outfd, xcolumn, ycolumn, lngcolumn, + latcolumn, lngunits, latunits, Memc[xformat], Memc[yformat], + Memc[lngformat], Memc[latformat], min_sigdigits, sx1, sy1, sx2, + sy2, mw, coo, forward, polar) + + # Do not get a new output file name if there is not output + # file list or if only one output file was specified. + # Otherwise fetch the new name. + if (fntlenb(outlist) > 1) { + call close (outfd) + if (fntgfnb (outlist, Memc[outfile], SZ_FNAME) != EOF) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + } + + call close (infd) + + # Do not reset the transformation if there is no record list + # or only one record is specified. Otherwise fetch the next + # record name. + if (reclist != NULL && imtlen (reclist) > 1) { + if (imtgetim (reclist, Memc[record], SZ_FNAME) != EOF) { + call cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + call cc_init_std (dt, Memc[record], geometry, + lngunits, latunits, sx1, sy1, sx2, sy2, mw, coo) + } + } + } + + # Free the surface descriptors. + call cc_free_std (sx1, sy1, sx2, sy2, mw, coo) + + # Close up file and record templates. + if (dt != NULL) + call dtunmap (dt) + call close (outfd) + call fntclsb (inlist) + call fntclsb (outlist) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + +end + + +# CC_TRANSFORM_STD -- This procedure is called once for each file in the +# input list. For each line in the input file that isn't blank or comment, +# the line is transformed. Blank and comment lines are output unaltered. + +procedure cc_transform_std (infd, outfd, xfield, yfield, lngfield, latfield, + lngunits, latunits, xformat, yformat, lngformat, latformat, + min_sigdigits, sx1, sy1, sx2, sy2, mw, coo, forward, polar) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int xfield #I the x column number +int yfield #I the y column number +int lngfield #I the ra / longitude column number +int latfield #I the dec / latitude column number +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units +char xformat[ARB] #I output format of the r / x coordinate +char yformat[ARB] #I output format of the t / y coordinate +char lngformat[ARB] #I output format of the r / longitude coordinate +char latformat[ARB] #I output format of the t / latitude coordinate +int min_sigdigits #I the minimum number of digits to be output +pointer sx1, sy1 #I pointers to the linear x and y surfaces +pointer sx2, sy2 #I pointers to the x and y distortion surfaces +pointer mw #I pointer to the mwcs structure +pointer coo #I pointer to the celestial coordinate structure +bool forward #I Is the transform in the forward direction ? +bool polar #I Polar standard coordinates ? + +double xd, yd, lngd, latd, txd, tyd, tlngd, tlatd +int max_fields, nline, nfields, nchars +int offset, tlngunits, tlatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ip, ct +pointer vfields, values, nsdigits, vformats +int getline(), li_get_numd(), sk_stati() +pointer mw_sctran() + +begin + # Allocate some working space. + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (vfields, 4, TY_INT) + call salloc (values, 4, TY_DOUBLE) + call salloc (nsdigits, 4, TY_INT) + call salloc (vformats, (SZ_FNAME + 1) * 4, TY_CHAR) + + # Determine the longitude and latitude units. + if (lngunits <= 0) { + if (coo == NULL) + tlngunits = SKY_HOURS + else + tlngunits = sk_stati (coo, S_NLNGUNITS) + } else + tlngunits = lngunits + if (latunits <= 0) { + if (coo == NULL) + tlatunits = SKY_DEGREES + else + tlatunits = sk_stati (coo, S_NLATUNITS) + } else + tlatunits = latunits + + # Set the output fields. + Memi[vfields] = xfield + Memi[vfields+1] = yfield + Memi[vfields+2] = lngfield + Memi[vfields+3] = latfield + + # If the formats are undefined set suitable default formats. + if (lngformat[1] == EOS) { + if (forward) + call strcpy ("%10.3f", Memc[vformats+2*(SZ_FNAME+1)], SZ_FNAME) + else { + switch (tlngunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[vformats+2*(SZ_FNAME+1)], + SZ_FNAME) + } + } + } else + call strcpy (lngformat, Memc[vformats+2*(SZ_FNAME+1)], SZ_FNAME) + + if (latformat[1] == EOS) { + if (forward) + call strcpy ("%10.3f", Memc[vformats+3*(SZ_FNAME+1)], SZ_FNAME) + else { + switch (tlatunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[vformats+3*(SZ_FNAME+1)], + SZ_FNAME) + } + } + } else + call strcpy (latformat, Memc[vformats+3*(SZ_FNAME+1)], SZ_FNAME) + + if (xformat[1] == EOS) + call strcpy ("%10.3f", Memc[vformats], SZ_FNAME) + else + call strcpy (xformat, Memc[vformats], SZ_FNAME) + if (yformat[1] == EOS) + call strcpy ("%10.3f", Memc[vformats+(SZ_FNAME+1)], SZ_FNAME) + else + call strcpy (yformat, Memc[vformats+(SZ_FNAME+1)], SZ_FNAME) + + + # If the transformation can be represented by mwcs then compile the + # appropriate transform. Other wise use the surface fitting code + # to do the transformation. + if (mw != NULL) { + if (forward) + ct = mw_sctran (mw, "world", "logical", 03B) + else + ct = mw_sctran (mw, "logical", "world", 03B) + } + + max_fields = MAX_FIELDS + for (nline=1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + for (ip=inbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # If the transformation is undefined then pass the line on + # undisturbed. + if (mw == NULL) { + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + # Check that all the data is present. + if (lngfield > nfields || latfield > nfields || xfield > nfields || + yfield > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Read the longitude / latitude or rstd / thetastd coordinates. + offset = Memi[field_pos+lngfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], lngd, + Memi[nsdigits+2]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad lng / xi value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+latfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], latd, + Memi[nsdigits+3]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad lat / eta value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Read the x and y or r and theta coordinates. + offset = Memi[field_pos+xfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], xd, Memi[nsdigits]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x / r value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + offset = Memi[field_pos+yfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], yd, Memi[nsdigits+1]) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y / theta value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Transform the longitude / latitude coordinates in lngunits / + # latunits to / from the xi / eta coordinates in arcseconds, and + # transform the x and y coordinates to or from the r and theta + # coordinates. + if (forward) { + switch (tlngunits) { + case SKY_RADIANS: + tlngd = RADTODEG(lngd) + case SKY_HOURS: + tlngd = 15.0d0 * lngd + default: + tlngd = lngd + } + switch (tlatunits) { + case SKY_RADIANS: + tlatd = RADTODEG(latd) + case SKY_HOURS: + tlatd = 15.0d0 * latd + default: + tlatd = latd + } + txd = xd + tyd = yd + } else if (polar) { + tlngd = lngd * cos (DEGTORAD(latd)) / 3600.0d0 + tlatd = lngd * sin (DEGTORAD(latd)) / 3600.0d0 + txd = xd * cos (DEGTORAD(yd)) + tyd = xd * sin (DEGTORAD(yd)) + } else { + tlngd = lngd / 3600.0d0 + tlatd = latd / 3600.0d0 + txd = xd + tyd = yd + } + call mw_c2trand (ct, tlngd, tlatd, lngd, latd) + call cc_do_std (txd, tyd, xd, yd, sx1, sy1, sx2, sy2, forward) + if (! forward) { + switch (tlngunits) { + case SKY_RADIANS: + Memd[values+2] = DEGTORAD(lngd) + case SKY_HOURS: + Memd[values+2] = lngd / 15.0d0 + default: + Memd[values+2] = lngd + } + switch (tlatunits) { + case SKY_RADIANS: + Memd[values+3] = DEGTORAD(latd) + case SKY_HOURS: + Memd[values+3] = latd / 15.0d0 + default: + Memd[values+3] = latd + } + Memd[values] = xd + Memd[values+1] = yd + } else if (polar) { + Memd[values] = sqrt (xd * xd + yd * yd) + Memd[values+1] = RADTODEG(atan2 (yd, xd)) + if (Memd[values+1] < 0.0d0) + Memd[values+1] = Memd[values+1] + 360.0d0 + Memd[values+2] = sqrt (lngd * lngd + latd * latd) * 3600.0d0 + Memd[values+3] = RADTODEG (atan2 (latd, lngd)) + if (Memd[values+3] < 0.0d0) + Memd[values+3] = Memd[values+3] + 360.0d0 + } else { + Memd[values] = xd + Memd[values+1] = yd + Memd[values+2] = lngd * 3600.0d0 + Memd[values+3] = latd * 3600.0d0 + } + + # Format the output line. + call li_npack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, Memi[vfields], Memd[values], + Memi[nsdigits], 4, Memc[vformats], SZ_FNAME, min_sigdigits) + + call putline (outfd, Memc[outbuf]) + } + + if (ct != NULL) + call mw_ctfree (ct) + + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_cctran.x b/pkg/images/imcoords/src/t_cctran.x new file mode 100644 index 00000000..6efeaf35 --- /dev/null +++ b/pkg/images/imcoords/src/t_cctran.x @@ -0,0 +1,374 @@ +include +include +include +include + + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# T_CCTRAN -- Transform a list of x and y coordinates to RA nad DEC or vice +# versa using the celestial coordinate transformation computed by the CCMAP +# task. + +procedure t_cctran() + +bool forward +int inlist, outlist, reclist, geometry, xcolumn, ycolumn, min_sigdigits +int infd, outfd, lngunits, latunits +pointer sp, infile, outfile, record, xformat, yformat, str, dt +pointer sx1, sy1, sx2, sy2, coo, mw +bool clgetb(), streq() +int fntopnb(), imtopenp(), fntlenb(), fntgfnb(), clgwrd(), clgeti() +int open(), imtgetim (), imtlen() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the input and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDIN", Memc[str], SZ_FNAME) + inlist = fntopnb(Memc[str], NO) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + call clgstr ("database", Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + dt = dtmap (Memc[str], READ_ONLY) + reclist = imtopenp ("solution") + } else { + dt = NULL + reclist = NULL + } + + # Test the input and out file and record lists for validity. + if (fntlenb(inlist) <= 0) + call error (0, "The input file list is empty") + if (fntlenb(outlist) <= 0) + call error (0, "The output file list is empty") + if (fntlenb(outlist) > 1 && fntlenb(outlist) != fntlenb(inlist)) + call error (0, + "Input and output file lists are not the same length") + if (dt != NULL && reclist != NULL) { + if (imtlen (reclist) > 1 && imtlen (reclist) != fntlenb (inlist)) + call error (0, + "Input file and record lists are not the same length.") + } + + # Get the fitting geometry. + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + forward = clgetb ("forward") + + # Get the input and output file parameters. + iferr (lngunits = clgwrd ("lngunits", Memc[str], SZ_LINE, + SKY_LNG_UNITLIST)) + lngunits = 0 + iferr (latunits = clgwrd ("latunits", Memc[str], SZ_LINE, + SKY_LAT_UNITLIST)) + latunits = 0 + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("lngformat", Memc[xformat], SZ_FNAME) + call clgstr ("latformat", Memc[yformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the output file name. + if (fntgfnb (outlist, Memc[outfile], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[outfile], SZ_FNAME) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + + # Get the record name. + if (reclist == NULL) + Memc[record] = EOS + else if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + Memc[record] = EOS + + # Call procedure to get parameters and fill structure. + coo = NULL; sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call cc_init_transform (dt, Memc[record], geometry, lngunits, + latunits, sx1, sy1, sx2, sy2, mw, coo) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[infile], SZ_FNAME) != EOF) { + + infd = open (Memc[infile], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call cc_transform_file (infd, outfd, xcolumn, ycolumn, lngunits, + latunits, Memc[xformat], Memc[yformat], min_sigdigits, sx1, + sy1, sx2, sy2, mw, coo, forward) + + # Do not get a new output file name if there is not output + # file list or if only one output file was specified. + # Otherwise fetch the new name. + if (fntlenb(outlist) > 1) { + call close (outfd) + if (fntgfnb (outlist, Memc[outfile], SZ_FNAME) != EOF) + outfd = open (Memc[outfile], NEW_FILE, TEXT_FILE) + if (streq (Memc[outfile], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + } + + call close (infd) + + # Do not reset the transformation if there is no record list + # or only one record is specified. Otherwise fetch the next + # record name. + if (reclist != NULL && imtlen (reclist) > 1) { + if (imtgetim (reclist, Memc[record], SZ_FNAME) != EOF) { + call cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + call cc_init_transform (dt, Memc[record], geometry, + lngunits, latunits, sx1, sy1, sx2, sy2, mw, coo) + } + } + } + + # Free the surface descriptors. + call cc_free_transform (sx1, sy1, sx2, sy2, mw, coo) + + # Close up file and record templates. + if (dt != NULL) + call dtunmap (dt) + call close (outfd) + call fntclsb (inlist) + call fntclsb (outlist) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) + +end + + +# CC_TRANSFORM_FILE -- This procedure is called once for each file +# in the input list. For each line in the input file that isn't +# blank or comment, the line is transformed. Blank and comment +# lines are output unaltered. + +procedure cc_transform_file (infd, outfd, xfield, yfield, lngunits, + latunits, xformat, yformat, min_sigdigits, sx1, sy1, sx2, sy2, + mw, coo, forward) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int xfield #I the x column number +int yfield #I the y column number +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units +char xformat[ARB] #I output format of the x coordinate +char yformat[ARB] #I output format of the y coordinate +int min_sigdigits #I the minimum number of digits to be output +pointer sx1, sy1 #I pointers to the linear x and y surfaces +pointer sx2, sy2 #I pointers to the x and y distortion surfaces +pointer mw #I pointer to the mwcs structure +pointer coo #I pointer to the celestial coordinate structure +bool forward #I forwards transform ? + +double xd, yd, xtd, ytd +int max_fields, nline, nfields, nchars, nsdig_x, nsdig_y, offset +int tlngunits, tlatunits +pointer sp, inbuf, linebuf, field_pos, outbuf, ip, ct, txformat, tyformat +int getline(), li_get_numd(), sk_stati() +pointer mw_sctran() + +begin + # Allocate some working space. + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + call salloc (txformat, SZ_LINE, TY_CHAR) + call salloc (tyformat, SZ_LINE, TY_CHAR) + + # Determine the units. + if (lngunits <= 0) { + if (coo == NULL) + tlngunits = SKY_HOURS + else + tlngunits = sk_stati (coo, S_NLNGUNITS) + } else + tlngunits = lngunits + if (latunits <= 0) { + if (coo == NULL) + tlatunits = SKY_DEGREES + else + tlatunits = sk_stati (coo, S_NLATUNITS) + } else + tlatunits = latunits + + # If the formats are undefined set suitable default formats. + if (xformat[1] == EOS) { + if (! forward) + call strcpy ("%10.3f", Memc[txformat], SZ_FNAME) + else { + switch (tlngunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[txformat], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[txformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[txformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[txformat], SZ_FNAME) + } + } + } else + call strcpy (xformat, Memc[txformat], SZ_FNAME) + + if (yformat[1] == EOS) { + if (! forward) + call strcpy ("%10.3f", Memc[tyformat], SZ_FNAME) + else { + switch (tlatunits) { + case SKY_HOURS: + call strcpy ("%12.2h", Memc[tyformat], SZ_FNAME) + case SKY_DEGREES: + call strcpy ("%11.1h", Memc[tyformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[tyformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[tyformat], SZ_FNAME) + } + } + } else + call strcpy (yformat, Memc[tyformat], SZ_FNAME) + + # If the transformation can be represented by mwcs then compile the + # appropriate transform. Other wise use the surface fitting code + # to do the transformation. + if (mw != NULL) { + if (forward) + ct = mw_sctran (mw, "logical", "world", 03B) + else + ct = mw_sctran (mw, "world", "logical", 03B) + } + + max_fields = MAX_FIELDS + for (nline=1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + + for (ip=inbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # If the transformation is undefined then pass the line on + # undisturbed. + if (mw == NULL) { + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + if (xfield > nfields || yfield > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+xfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], xd, nsdig_x) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+yfield-1] + nchars = li_get_numd (Memc[linebuf+offset-1], yd, nsdig_y) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + # Transform the coordinates. + if (! forward) { + switch (tlngunits) { + case SKY_RADIANS: + xd = RADTODEG(xd) + case SKY_HOURS: + xd = 15.0d0 * xd + default: + ; + } + switch (tlatunits) { + case SKY_RADIANS: + yd = RADTODEG(yd) + case SKY_HOURS: + yd = 15.0d0 * yd + default: + ; + } + } + if (sx2 != NULL || sy2 != NULL) + call cc_do_transform (xd, yd, xtd, ytd, ct, sx1, sy1, + sx2, sy2, forward) + else + call mw_c2trand (ct, xd, yd, xtd, ytd) + if (forward) { + switch (tlngunits) { + case SKY_RADIANS: + xtd = DEGTORAD(xtd) + case SKY_HOURS: + xtd = xtd / 15.0d0 + default: + ; + } + switch (tlatunits) { + case SKY_RADIANS: + ytd = DEGTORAD(ytd) + case SKY_HOURS: + ytd = ytd / 15.0d0 + default: + ; + } + } + + # Format the output line. + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtd, ytd, + Memc[txformat], Memc[tyformat], nsdig_x, nsdig_y, min_sigdigits) + + call putline (outfd, Memc[outbuf]) + } + + if (ct != NULL) + call mw_ctfree (ct) + + call sfree (sp) +end + diff --git a/pkg/images/imcoords/src/t_ccxymatch.x b/pkg/images/imcoords/src/t_ccxymatch.x new file mode 100644 index 00000000..ea34b6c0 --- /dev/null +++ b/pkg/images/imcoords/src/t_ccxymatch.x @@ -0,0 +1,576 @@ +include +include +include "../../lib/xyxymatch.h" + +# T_CCXYMATCH -- This task computes the intersection of a set of pixel +# coordinate lists with a reference celestial coordinate list. The output is +# the set of objects common to both lists. In its simplest form CCXYMATCH +# uses a matching tolerance to generate the common list. Alternatively +# CCXYMATCH can use coordinate transformation information derived from the +# positions of one to three stars common to both lists, a sorting algorithm, +# and a matching tolerance to generate the common list. A more sophisticated +# pattern matching algorithm is also available which requires no coordinate +# transformation input from the user but is expensive computationally. + +procedure t_ccxymatch() + +bool verbose +double lngin, latin, tlngin, tlatin +int ilist, rlist, olist, xcol, ycol, lngcol, latcol, lngunits, latunits +int match, maxntriangles, nreject, rfd, rpfd, ifd, ofd, pfd +int ntrefstars, nreftie, nrefstars, nrmaxtri, nreftri, nintie, ntie +int ntliststars, nliststars, ninter, ninmaxtri, nintri, proj +pointer sp, inname, refname, outname, refpoints, xreftie, yreftie +pointer xintie, yintie, coeff, projection, str +pointer xformat, yformat, lngformat, latformat +pointer lngref, latref, xref, yref, rlineno, rsindex, reftri, reftrirat +pointer xtrans, ytrans, listindex, xlist, ylist, ilineno, intri, intrirat +real tolerance, ptolerance, xin, yin, xmag, ymag, xrot, yrot +real pseparation, separation, ratio + +bool clgetb() +double clgetd() +int fstati(), clpopnu(), clplen(), clgeti(), clgwrd(), open(), clgfil() +int rg_getrefcel(), rg_rdlli(), rg_sort(), rg_factorial(), rg_triangle() +int rg_getreftie(), rg_lincoeff(), rg_rdxyi(), rg_llintersect() +int rg_match(), rg_mlincoeff(), cc_rdproj(), strdic() +real clgetr() +errchk open() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (refname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (refpoints, SZ_FNAME, TY_CHAR) + call salloc (xreftie, MAX_NTIE, TY_REAL) + call salloc (yreftie, MAX_NTIE, TY_REAL) + call salloc (xintie, MAX_NTIE, TY_REAL) + call salloc (yintie, MAX_NTIE, TY_REAL) + call salloc (coeff, MAX_NCOEFF, TY_REAL) + call salloc (projection, SZ_LINE, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (lngformat, SZ_FNAME, TY_CHAR) + call salloc (latformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input, output, and reference lists. + ilist = clpopnu ("input") + rlist = clpopnu ("reference") + olist = clpopnu ("output") + tolerance = clgetr ("tolerance") + match = clgwrd ("matching", Memc[str], SZ_LINE, RG_MATCHSTR) + if (match == RG_TRIANGLES) + ptolerance = clgetr ("ptolerance") + else + ptolerance = tolerance + + call clgstr ("refpoints", Memc[refpoints], SZ_FNAME) + + # Check the input and output file lengths. + if (clplen (rlist) > 1 && clplen (rlist) != clplen (ilist)) + call error (0, + "The number of input and reference lists are not the same") + if (clplen (ilist) != clplen (olist)) + call error (0, + "The number of input and output lists are not the same") + + xcol = clgeti ("xcolumn") + ycol = clgeti ("ycolumn") + lngcol = clgeti ("lngcolumn") + latcol = clgeti ("latcolumn") + lngunits = clgwrd ("lngunits", Memc[str], SZ_FNAME, SKY_LNG_UNITLIST) + latunits = clgwrd ("latunits", Memc[str], SZ_FNAME, SKY_LAT_UNITLIST) + + call clgstr ("projection", Memc[projection], SZ_LINE) + iferr { + pfd = open (Memc[projection], READ_ONLY, TEXT_FILE) + } then { + proj = strdic (Memc[projection], Memc[projection], SZ_LINE, + WTYPE_LIST) + if (proj <= 0 || proj == WTYPE_LIN) + Memc[projection] = EOS + } else { + proj = cc_rdproj (pfd, Memc[projection], SZ_LINE) + call close (pfd) + } + + # Get the matching parameters. + xin = clgetr ("xin") + if (IS_INDEFR(xin)) + xin = 0.0 + yin = clgetr ("yin") + if (IS_INDEFR(yin)) + yin = 0.0 + xmag = clgetr ("xmag") + if (IS_INDEFR(xmag)) + xmag = 1.0 + ymag = clgetr ("ymag") + if (IS_INDEFR(ymag)) + ymag = 1.0 + xrot = clgetr ("xrotation") + if (IS_INDEFR(xrot)) + xrot = 0.0 + yrot = clgetr ("yrotation") + if (IS_INDEFR(yrot)) + yrot = 0.0 + lngin = clgetd ("lngref") + latin = clgetd ("latref") + + # Get the algorithm parameters. + pseparation = clgetr ("pseparation") + separation = clgetr ("separation") + maxntriangles = clgeti ("nmatch") + ratio = clgetr ("ratio") + nreject = clgeti ("nreject") + + # Get the output formatting parameters. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + call clgstr ("lngformat", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + switch (lngunits) { + case SKY_HOURS, SKY_DEGREES: + call strcpy ("%13.3h", Memc[lngformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[lngformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[lngformat], SZ_FNAME) + } + } else + call strcpy (Memc[str], Memc[lngformat], SZ_FNAME) + call clgstr ("latformat", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) { + switch (latunits) { + case SKY_HOURS, SKY_DEGREES: + call strcpy ("%13.2h", Memc[latformat], SZ_FNAME) + case SKY_RADIANS: + call strcpy ("%13.7g", Memc[latformat], SZ_FNAME) + default: + call strcpy ("%10.3f", Memc[latformat], SZ_FNAME) + } + } else + call strcpy (Memc[str], Memc[latformat], SZ_FNAME) + + verbose = clgetb ("verbose") + + # Open the reference list file if any. + rfd = NULL + if (Memc[refpoints] == EOS) + rpfd = NULL + else + rpfd = open (Memc[refpoints], READ_ONLY, TEXT_FILE) + + # Initialize. + lngref = NULL + latref = NULL + xref = NULL + yref = NULL + rsindex = NULL + rlineno = NULL + + # Loop over the input lists. + while (clgfil (ilist, Memc[inname], SZ_FNAME) != EOF && + clgfil (olist, Memc[outname], SZ_FNAME) != EOF) { + + # Open the input list. + ifd = open (Memc[inname], READ_ONLY, TEXT_FILE) + + # Open the output list. + ofd = open (Memc[outname], NEW_FILE, TEXT_FILE) + + # Open the reference list and get the coordinates. + while (clgfil (rlist, Memc[refname], SZ_FNAME) != EOF) { + + # Open the reference file. + if (rfd != NULL) + call close (rfd) + rfd = open (Memc[refname], READ_ONLY, TEXT_FILE) + + # Read the reference data. + if (lngref != NULL) + call mfree (lngref, TY_DOUBLE) + if (latref != NULL) + call mfree (latref, TY_DOUBLE) + if (xref != NULL) + call mfree (xref, TY_REAL) + if (yref != NULL) + call mfree (yref, TY_REAL) + if (rlineno != NULL) + call mfree (rlineno, TY_INT) + if (rsindex != NULL) + call mfree (rsindex, TY_INT) + ntrefstars = rg_rdlli (rfd, lngref, latref, xref, yref, rlineno, + tlngin, tlatin, lngcol, latcol, Memc[projection], lngin, + latin, lngunits, latunits) + + # Prepare the reference list for the merge algorithm. If a tie + # point matching algorithm is selected, sort the list in the + # y and then the x coordinate and remove coincident points. + # If the pattern matching algorithm is used then construct the + # triangles used for matching and sort them in order of + # increasing ratio. + + call malloc (rsindex, ntrefstars, TY_INT) + nrefstars = rg_sort (Memr[xref], Memr[yref], Memi[rsindex], + ntrefstars, separation, YES, YES) + if (match != RG_TRIANGLES) { + reftri = NULL + reftrirat = NULL + nreftri = nrefstars + } else if (nrefstars > 2) { + nrmaxtri = rg_factorial (min (nrefstars, maxntriangles), 3) + call calloc (reftri, SZ_TRIINDEX * nrmaxtri, TY_INT) + call calloc (reftrirat, SZ_TRIPAR * nrmaxtri, TY_REAL) + nreftri = rg_triangle (Memr[xref], Memr[yref], + Memi[rsindex], nrefstars, Memi[reftri], + Memr[reftrirat], nrmaxtri, maxntriangles, + tolerance, ratio) + } else { + nreftri = 0 + reftri = NULL + reftrirat = NULL + } + + + # Fetch the reference tie points if any. + if (rpfd != NULL) + nreftie = rg_getrefcel (rpfd, Memr[xreftie], Memr[yreftie], + 3, Memc[projection], tlngin, tlatin, lngunits, latunits, + RG_REFFILE) + else + nreftie = 0 + + break + } + + # Fetch the input tie points and compute the coefficients. + if (rpfd != NULL) + nintie = rg_getreftie (rpfd, Memr[xintie], + Memr[yintie], nreftie, RG_INFILE, false) + else + nintie = 0 + ntie = min (nreftie, nintie) + if (ntie <= 0) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + 0.0, 0.0, Memr[coeff], MAX_NCOEFF) + else if (rg_lincoeff (Memr[xreftie], Memr[yreftie], + Memr[xintie], Memr[yintie], ntie, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + 0.0, 0.0, Memr[coeff], MAX_NCOEFF) + + # Print the header. + if (verbose) { + call printf ("\nInput: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call printf ("Number of tie points: %d\n") + call pargi (ntie) + } + call fprintf (ofd, "\n# Input: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call fprintf (ofd, "Number of tie points: %d\n") + call pargi (ntie) + + # Print the coordinate transformation information. + if (verbose) + call rg_plincoeff (" xi", " eta", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + call rg_wlincoeff (ofd, " xi", " eta", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + + # Read in the input list. + xtrans = NULL + ytrans = NULL + listindex = NULL + ntliststars = rg_rdxyi (ifd, xlist, ylist, ilineno, xcol, ycol) + + # Compute the intersection of the two lists using either an + # algorithm depending on common tie points or on a more + # sophisticated pattern matching algorithm. + + if (ntrefstars <= 0) { + if (verbose) + call printf (" The reference coordinate list is empty\n") + ninter = 0 + } else if (ntliststars <= 0) { + if (verbose) + call printf (" The input coordinate list is empty\n") + ninter = 0 + } else if (nreftri <= 0) { + if (verbose) + call printf ( + " No valid reference triangles can be defined\n") + } else { + call malloc (xtrans, ntliststars, TY_REAL) + call malloc (ytrans, ntliststars, TY_REAL) + call malloc (listindex, ntliststars, TY_INT) + call rg_compute (Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], ntliststars, Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, YES, YES) + if (match != RG_TRIANGLES) { + intri = NULL + intrirat = NULL + nintri = nliststars + call rg_pllcolumns (ofd) + ninter = rg_llintersect (ofd, Memd[lngref], Memd[latref], + Memr[xref], Memr[yref], Memi[rsindex], Memi[rlineno], + nrefstars, Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], Memi[listindex], Memi[ilineno], + nliststars, tolerance, Memc[lngformat], + Memc[latformat],Memc[xformat], Memc[yformat]) + } else if (nliststars > 2) { + ninmaxtri = rg_factorial (min (max(nliststars,nrefstars), + maxntriangles), 3) + call calloc (intri, SZ_TRIINDEX * ninmaxtri, TY_INT) + call calloc (intrirat, SZ_TRIPAR * ninmaxtri, TY_REAL) + nintri = rg_triangle (Memr[xtrans], Memr[ytrans], + Memi[listindex], nliststars, Memi[intri], + Memr[intrirat], ninmaxtri, maxntriangles, + ptolerance, ratio) + if (nintri <= 0) { + if (verbose) + call printf ( + " No valid input triangles can be defined\n") + } else { + ninter = rg_match (Memr[xref], Memr[yref], nrefstars, + Memr[xtrans], Memr[ytrans], nliststars, + Memi[reftri], Memr[reftrirat], nreftri, nrmaxtri, + ntrefstars, Memi[intri], Memr[intrirat], nintri, + ninmaxtri, ntliststars, tolerance, ptolerance, + ratio, nreject) + } + if (nrefstars <= maxntriangles && nliststars <= + maxntriangles) { + call rg_pllcolumns (ofd) + call rg_lmwrite (ofd, Memd[lngref], Memd[latref], + Memi[rlineno], Memr[xlist], Memr[ylist], + Memi[ilineno], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memc[lngformat], + Memc[latformat], Memc[xformat], Memc[yformat]) + } else { + if (rg_mlincoeff (Memr[xref], Memr[yref], Memr[xlist], + Memr[ylist], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + 0.0, 0.0, Memr[coeff], MAX_NCOEFF) + call rg_compute (Memr[xlist], Memr[ylist], + Memr[xtrans], Memr[ytrans], ntliststars, + Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, + YES, YES) + if (verbose) + call rg_pmlincoeff (" xi", " eta", Memr[coeff], + MAX_NCOEFF) + call rg_wmlincoeff (ofd, " xi", " eta", Memr[coeff], + MAX_NCOEFF) + call rg_pllcolumns (ofd) + ninter = rg_llintersect (ofd, Memd[lngref], + Memd[latref], Memr[xref], Memr[yref], Memi[rsindex], + Memi[rlineno], nrefstars, Memr[xlist], Memr[ylist], + Memr[xtrans], Memr[ytrans], Memi[listindex], + Memi[ilineno], nliststars, tolerance, + Memc[lngformat], Memc[latformat], Memc[xformat], + Memc[yformat]) + } + } else { + if (verbose) + call printf ( + "\tThe input coordinate list has < 3 stars\n") + intri = NULL + intrirat = NULL + nintri = 0 + ninter = 0 + } + } + + # Print out the number of stars matched in the two lists. + if (verbose) { + call printf ("%d reference coordinates matched\n") + call pargi (ninter) + } + + # Free space used by input list. + call mfree (xlist, TY_REAL) + call mfree (ylist, TY_REAL) + call mfree (ilineno, TY_INT) + call mfree (listindex, TY_INT) + if (xtrans != NULL) + call mfree (xtrans, TY_REAL) + if (ytrans != NULL) + call mfree (ytrans, TY_REAL) + if (intri != NULL) + call mfree (intri, TY_INT) + if (intrirat != NULL) + call mfree (intrirat, TY_REAL) + + # Close the input and output lists. + call close (ifd) + call close (ofd) + } + + # Release the memory used to store the reference list. + call mfree (lngref, TY_DOUBLE) + call mfree (latref, TY_DOUBLE) + call mfree (xref, TY_REAL) + call mfree (yref, TY_REAL) + call mfree (rlineno, TY_INT) + call mfree (rsindex, TY_INT) + if (reftri != NULL) + call mfree (reftri, TY_INT) + if (reftrirat != NULL) + call mfree (reftrirat, TY_REAL) + + # Close the reference file. + if (rfd != NULL) + call close (rfd) + + # Close the reference points file. + if (rpfd != NULL) + call close (rpfd) + + # Close the file lists. + call clpcls (ilist) + call clpcls (rlist) + call clpcls (olist) + + call sfree (sp) +end + + +# RG_RDLLI -- Read in the celestial coordinates from a file, convert them +# to standard coordinates, and set the line number index. + +int procedure rg_rdlli (fd, lng, lat, x, y, lineno, tlngref, tlatref, + xcolumn, ycolumn, projection, lngref, latref, lngunits, latunits) + +int fd #I the input file descriptor +pointer lng #U pointer to the x coordinates +pointer lat #U pointer to the y coordinates +pointer x #U pointer to the x coordinates +pointer y #U pointer to the y coordinates +pointer lineno #U pointer to the line numbers +double tlngref #O the adopted reference ra / longitude +double tlatref #O the adopted reference dec / latitude +int xcolumn #I column containing the x coordinate +int ycolumn #I column containing the y coordinate +char projection[ARB] #I the sky projection geometry +double lngref #I the input reference ra / longitude +double latref #I the input reference dec / latitude +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units + +int i, ip, bufsize, npts, lnpts, maxcols +double xval, yval +pointer sp, str, tx, ty +int fscan(), nscan(), ctod() +double asumd() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + bufsize = DEF_BUFSIZE + call malloc (lng, bufsize, TY_DOUBLE) + call malloc (lat, bufsize, TY_DOUBLE) + call malloc (x, bufsize, TY_REAL) + call malloc (y, bufsize, TY_REAL) + call malloc (lineno, bufsize, TY_INT) + maxcols = max (xcolumn, ycolumn) + + npts = 0 + lnpts = 0 + while (fscan(fd) != EOF) { + + lnpts = lnpts + 1 + xval = INDEFD + yval = INDEFD + do i = 1, maxcols { + call gargwrd (Memc[str], SZ_LINE) + if (i != nscan()) + break + ip = 1 + if (i == xcolumn) { + if (ctod (Memc[str], ip, xval) <= 0) + xval = INDEFD + } else if (i == ycolumn) { + if (ctod (Memc[str], ip, yval) <= 0) + yval = INDEFD + } + } + if (IS_INDEFD(xval) || IS_INDEFD(yval)) + next + + Memd[lng+npts] = xval + Memd[lat+npts] = yval + Memi[lineno+npts] = lnpts + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + DEF_BUFSIZE + call realloc (lng, bufsize, TY_DOUBLE) + call realloc (lat, bufsize, TY_DOUBLE) + call realloc (x, bufsize, TY_REAL) + call realloc (y, bufsize, TY_REAL) + call realloc (lineno, bufsize, TY_INT) + } + } + + # Compute the reference point and convert to standard coordinates. + if (npts > 0) { + if (IS_INDEFD(lngref)) + tlngref = asumd (Memd[lng], npts) / npts + else + tlngref = lngref + if (IS_INDEFD(latref)) + tlatref = asumd (Memd[lat], npts) / npts + else + tlatref = latref + call salloc (tx, npts, TY_DOUBLE) + call salloc (ty, npts, TY_DOUBLE) + call rg_celtostd (projection, Memd[lng], Memd[lat], Memd[tx], + Memd[ty], npts, tlngref, tlatref, lngunits, latunits) + call amulkd (Memd[tx], 3600.0d0, Memd[tx], npts) + call amulkd (Memd[ty], 3600.0d0, Memd[ty], npts) + call achtdr (Memd[tx], Memr[x], npts) + call achtdr (Memd[ty], Memr[y], npts) + } else { + tlngref = lngref + tlatref = latref + } + + call sfree (sp) + + return (npts) +end + + +# RG_PLLCOLUMNS -- Print the column descriptions in the output file. + +procedure rg_pllcolumns (ofd) + +int ofd #I the output file descriptor + +begin + call fprintf (ofd, "# Column definitions\n") + call fprintf (ofd, + "# Column 1: Reference Ra / Longitude coordinate\n") + call fprintf (ofd, + "# Column 2: Reference Dec / Latitude coordinate\n") + call fprintf (ofd, "# Column 3: Input X coordinate\n") + call fprintf (ofd, "# Column 4: Input Y coordinate\n") + call fprintf (ofd, "# Column 5: Reference line number\n") + call fprintf (ofd, "# Column 6: Input line number\n") + call fprintf (ofd, "\n") +end diff --git a/pkg/images/imcoords/src/t_hpctran.x b/pkg/images/imcoords/src/t_hpctran.x new file mode 100644 index 00000000..aa398186 --- /dev/null +++ b/pkg/images/imcoords/src/t_hpctran.x @@ -0,0 +1,136 @@ +include + +define DIRS "|ang2row|row2ang|" +define ANG2PIX 1 +define PIX2ANG 2 + +define CUNITS "|hourdegree|degrees|radians|" +define H 1 +define D 2 +define R 3 + +define MTYPES "|nest|ring|" +define NEST 1 +define RING 2 + + +# T_HPCTRAN -- Convert between HEALPix rows and spherical coordinates. +# +# It is up to the user to know the coordinate and map type; e.g. +# galactic/nested, equatorial/ring. However, the use can use +# whatever units for the coordinate type; e.g. hours/degrees, radians. +# +# The HEALPix row is 1 indexed to be consistent with IRAF conventions. +# This row can be used to access the map data with TTOOLS tasks. + +procedure t_hpctran () + +int dir # Direction (ang2row|row2ang) +int row # HEALpix map row (1 indexed) +double lng # RA/longitude +double lat # DEC/latitude +int nside # Resolution parameter +int cunits # Coordinate units +int mtype # HEALpix map type + +char str[10] + +int clgeti(), clgwrd() +double clgetd() +errchk ang2row, row2ang + +begin + # Get parameters. + dir = clgwrd ("direction", str, 10, DIRS) + nside = clgeti ("nside") + cunits = clgwrd ("cunits", str, 10, CUNITS) + mtype = clgwrd ("maptype", str, 10, MTYPES) + + switch (dir) { + case ANG2PIX: + lng = clgetd ("lng") + lat = clgetd ("lat") + switch (cunits) { + case 0: + call error (1, "Unknown coordinate units") + case H: + lng = lng * 15D0 + case R: + lng = RADTODEG(lng) + lat = RADTODEG(lat) + } + + call ang2row (row, lng, lat, mtype, nside) + + call clputi ("row", row) + case PIX2ANG: + row = clgeti ("row") + + call row2ang (row, lng, lat, mtype, nside) + + switch (cunits) { + case 0: + call error (1, "Unknown coordinate units") + case H: + lng = lng / 15D0 + case R: + lng = DEGTORAD(lng) + lat = DEGTORAD(lat) + } + + call clputd ("lng", lng) + call clputd ("lat", lat) + } + + # Output the map row. + call printf ("%d %g %g\n") + call pargi (row) + call pargd (lng) + call pargd (lat) +end + + +# TEST_HEALPIX2 -- Test routine as in the HEALPix distribution. + +procedure test_healpix2 () + +double theta, phi +int nside +int ipix, npix, dpix, ip1 + +begin + + call printf("Starting C Healpix pixel routines test\n") + + nside = 1024 + dpix = 23 + + # Find the number of pixels in the full map + npix = 12*nside*nside + call printf("Number of pixels in full map: %d\n") + call pargi (npix) + + call printf("dpix: %d\n") + call pargi (dpix) + call printf("Nest -> ang -> Ring -> ang -> Nest\n") +# call printf("Nest -> ang -> Nest\n") +# call printf("Ring -> ang -> Ring\n") + for (ipix = 0; ipix < npix; ipix = ipix + dpix) { + call pix2ang_nest(nside, ipix, theta, phi) + call ang2pix_ring(nside, theta, phi, ip1) + call pix2ang_ring(nside, ip1, theta, phi) + call ang2pix_nest(nside, theta, phi, ip1) +# call pix2ang_ring(nside, ipix, theta, phi) +# call ang2pix_ring(nside, theta, phi, ip1) + if (ip1 != ipix) { + call printf("Error: %d %d %d\n") + call pargi (nside) + call pargi (ipix) + call pargi (ip1) + } + } + + call printf("%d\n") + call pargi (nside) + call printf("test completed\n\n") +end diff --git a/pkg/images/imcoords/src/t_imcctran.x b/pkg/images/imcoords/src/t_imcctran.x new file mode 100644 index 00000000..4729a85d --- /dev/null +++ b/pkg/images/imcoords/src/t_imcctran.x @@ -0,0 +1,922 @@ +include +include +include +include +include +include + +procedure t_imcctran () + +double tilng, tilat, tolng, tolat, xscale, yscale, xrot, yrot, xrms, yrms +double olongpole, olatpole, nlongpole, nlatpole +pointer sp, imtemplate, insystem, outsystem, image, str +pointer im, mwin, cooin, mwout, cooout, ctin, ctout +pointer r, w, cd, ltm, ltv, iltm, nr, ncd, jr +pointer ix, iy, ox, oy, ilng, ilat, olng, olat +int imlist, nxgrid, nygrid, npts, instat, outstat, ndim, fitstat, axbits +bool uselp, verbose, update, usecd + +double rg_rmsdiff() +pointer immap(), rg_xytoxy(), mw_newcopy() +int fstati(), imtopen(), imtgetim(), sk_decim(), sk_decwcs(), mw_stati() +int clgeti(), sk_stati(), rg_cdfit() +bool clgetb(), rg_longpole() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (imtemplate, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the list of images and output coordinate system. + call clgstr ("image", Memc[imtemplate], SZ_FNAME) + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + + # Get the remaining parameters. + nxgrid = clgeti ("nx") + nygrid = clgeti ("ny") + npts = nxgrid * nygrid + uselp = clgetb ("longpole") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the list of images + imlist = imtopen (Memc[imtemplate]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image after removing any section notation. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + if (update) + im = immap (Memc[image], READ_WRITE, 0) + else + im = immap (Memc[image], READ_ONLY, 0) + if (verbose) { + call printf ("INPUT IMAGE: %s\n") + call pargstr (Memc[image]) + } + + # Create the input system name. + call sprintf (Memc[insystem], SZ_FNAME, "%s logical") + call pargstr (Memc[image]) + + # Open the input image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (verbose) { + if (instat == ERR || mwin == NULL) + call printf ("Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[insystem], mwin, cooin) + } + if (instat == ERR || mwin == NULL) { + if (mwin != NULL) + call mw_close (mwin) + #call mfree (cooin, TY_STRUCT) + call sk_close (cooin) + call imunmap (im) + next + } + + # Open the output coordinate system. + outstat = sk_decwcs (Memc[outsystem], mwout, cooout, cooin) + if (verbose) { + if (outstat == ERR || mwout != NULL) + call printf ( + "Error decoding the output coordinate system\n") + call sk_iiprint ("Outsystem", Memc[outsystem], mwout, cooout) + } + if (outstat == ERR || mwout != NULL) { + if (mwout != NULL) + call mw_close (mwout) + #call mfree (cooout, TY_STRUCT) + call sk_close (cooout) + call sfree (sp) + return + } + + # Get the dimensionality of the wcs. + ndim = mw_stati (mwin, MW_NPHYSDIM) + + # Allocate working memory for the vectors and matrices. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim, TY_DOUBLE) + call malloc (jr, ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + # Allocate working memory for the grid points. + call malloc (ix, npts, TY_DOUBLE) + call malloc (iy, npts, TY_DOUBLE) + call malloc (ilng, npts, TY_DOUBLE) + call malloc (ilat, npts, TY_DOUBLE) + call malloc (ox, npts, TY_DOUBLE) + call malloc (oy, npts, TY_DOUBLE) + call malloc (olng, npts, TY_DOUBLE) + call malloc (olat, npts, TY_DOUBLE) + + # Compute the original logical to world transformation. + call mw_gltermd (mwin, Memd[ltm], Memd[ltv], ndim) + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + + # Compute the logical and world coordinates of the input image + # grid points. + call rg_rxyl (Memd[ix], Memd[iy], nxgrid, nygrid, 1.0d0, + double(sk_stati(cooin, S_NLNGAX)), 1.0d0, + double(sk_stati(cooin, S_NLATAX))) + ctin = rg_xytoxy (mwin, Memd[ix], Memd[iy], Memd[ilng], Memd[ilat], + npts, "logical", "world", sk_stati (cooin, S_XLAX), + sk_stati (cooin, S_YLAX)) + + # Transfrom the input image grid points to the new world coordinate + # system. + call rg_lltransform (cooin, cooout, Memd[ilng], Memd[ilat], + Memd[olng], Memd[olat], npts) + + # Get the reference point. + if (sk_stati(cooin, S_PLNGAX) < sk_stati(cooin, S_PLATAX)) { + tilng = Memd[w+sk_stati(cooin,S_PLNGAX)-1] + tilat = Memd[w+sk_stati(cooin,S_PLATAX)-1] + } else { + tilng = Memd[w+sk_stati(cooin,S_PLATAX)-1] + tilat = Memd[w+sk_stati(cooin,S_PLNGAX)-1] + } + + # Compute the value of longpole and latpole required to transform + # the coordinate system. + usecd = rg_longpole (mwin, cooin, cooout, tilng, tilat, olongpole, + olatpole, nlongpole, nlatpole) + if (uselp) + usecd = false + + # Output the current image wcs. + if (verbose && ! update) { + call printf ("\n") + call rg_wcsshow (mwin, "Current", Memd[ltv], Memd[ltm], Memd[w], + Memd[nr], Memd[ncd], ndim, olongpole, olatpole) + } + + # Compute the new world coordinates of the reference point and + # update the reference point vector. + call rg_lltransform (cooin, cooout, tilng, tilat, tolng, tolat, 1) + if (sk_stati(cooout, S_PLNGAX) < sk_stati(cooout, S_PLATAX)) { + Memd[w+sk_stati(cooout,S_PLNGAX)-1] = tolng + Memd[w+sk_stati(cooout,S_PLATAX)-1] = tolat + } else { + Memd[w+sk_stati(cooout,S_PLNGAX)-1] = tolat + Memd[w+sk_stati(cooout,S_PLATAX)-1] = tolng + } + + # Initialize the output transfrom. + mwout = mw_newcopy (mwin) + + # Set the terms. + call mw_swtermd (mwout, Memd[r], Memd[w], Memd[cd], ndim) + + if (usecd) { + + # Compute the new x and y values. + ctout = rg_xytoxy (mwout, Memd[olng], Memd[olat], Memd[ox], + Memd[oy], npts, "world", "logical", sk_stati (cooout, + S_XLAX), sk_stati (cooout, S_YLAX)) + + # Subtract off the origin and compute the coordinate system + # rotation angle and scale factor. + call asubkd (Memd[ix], Memd[nr+sk_stati(cooin, S_XLAX)-1], + Memd[ix], npts) + call asubkd (Memd[iy], Memd[nr+sk_stati(cooin, S_YLAX)-1], + Memd[iy], npts) + call asubkd (Memd[ox], Memd[nr+sk_stati(cooout, S_XLAX)-1], + Memd[ox], npts) + call asubkd (Memd[oy], Memd[nr+sk_stati(cooout, S_YLAX)-1], + Memd[oy], npts) + fitstat = rg_cdfit (Memd[ix], Memd[iy], Memd[ox], Memd[oy], + npts, xscale, yscale, xrot, yrot) + + } else { + + ctout = NULL + xscale = 1.0d0 + yscale = 1.0d0 + xrot = 0.0d0 + yrot = 0.0d0 + fitstat = OK + } + + if (fitstat == OK) { + + # Modify the cd matrix. + if (usecd) { + + axbits = 2 ** (sk_stati (cooout, S_XLAX) - 1) + + 2 ** (sk_stati (cooout, S_YLAX) - 1) + call rg_mwxyrot (mwout, xscale, yscale, xrot, yrot, + Memd[ncd], Memd[cd], ndim, axbits) + call mwmmuld (Memd[cd], Memd[ltm], Memd[ncd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[jr], ndim) + call mw_swtermd (mwout, Memd[jr], Memd[w], Memd[ncd], ndim) + + # Modify longpole and latpole. + } else { + call sprintf (Memc[str], SZ_LINE, "%g") + call pargd (nlongpole) + #call eprintf ("longpole='%s'\n") + #call pargstr (Memc[str]) + call mw_swattrs (mwout, sk_stati(cooout, S_PLNGAX), + "longpole", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "%g") + call pargd (nlatpole) + #call eprintf ("latpole='%s'\n") + #call pargstr (Memc[str]) + call mw_swattrs (mwout, sk_stati(cooout, S_PLATAX), + "latpole", Memc[str]) + call amovd (Memd[ncd], Memd[cd], ndim * ndim) + } + + # Compute and print the goodness of fit estimate. + if (verbose) { + if (ctout != NULL) + call mw_ctfree (ctout) + ctout = rg_xytoxy (mwout, Memd[olng], Memd[olat], + Memd[ox], Memd[oy], npts, "world", "logical", + sk_stati (cooout, S_XLAX), sk_stati (cooout, S_YLAX)) + if (usecd) { + call aaddkd (Memd[ix], Memd[nr+sk_stati(cooout, + S_XLAX)-1], Memd[ix], npts) + call aaddkd (Memd[iy], Memd[nr+sk_stati(cooout, + S_YLAX)-1], Memd[iy], npts) + } + xrms = rg_rmsdiff (Memd[ox], Memd[ix], npts) + yrms = rg_rmsdiff (Memd[oy], Memd[iy], npts) + } + + # Recompute and store the new wcs if update is enabled. + if (update) { + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + } else if (verbose) { + if (usecd) + call rg_wcsshow (mwin, "New", Memd[ltv], Memd[ltm], + Memd[w], Memd[nr], Memd[cd], ndim, olongpole, + olatpole) + else + call rg_wcsshow (mwin, "New", Memd[ltv], Memd[ltm], + Memd[w], Memd[nr], Memd[cd], ndim, nlongpole, + nlatpole) + } + + if (verbose) { + call printf ( + "Crval%d,%d: %h, %h -> %h, %h dd:mm:ss.s\n") + call pargi (sk_stati(cooout,S_PLNGAX)) + call pargi (sk_stati(cooout,S_PLATAX)) + call pargd (tilng) + call pargd (tilat) + call pargd (tolng) + call pargd (tolat) + call printf (" Scaling: Xmag: %0.6f Ymag: %0.6f ") + call pargd (xscale) + call pargd (yscale) + call printf ("Xrot: %0.3f Yrot: %0.3f degrees\n") + call pargd (xrot) + call pargd (yrot) + call printf ( + " Rms: X fit: %0.7g pixels Y fit: %0.7g pixels\n") + call pargd (xrms) + call pargd (yrms) + call printf ("\n") + } + + } else + call printf ("Error fitting the scaling factors angle\n") + + # Free the memory. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (jr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + call mfree (ix, TY_DOUBLE) + call mfree (iy, TY_DOUBLE) + call mfree (ilng, TY_DOUBLE) + call mfree (ilat, TY_DOUBLE) + call mfree (ox, TY_DOUBLE) + call mfree (oy, TY_DOUBLE) + call mfree (olng, TY_DOUBLE) + call mfree (olat, TY_DOUBLE) + + # Clean up various data stuctures. + if (mwin != NULL) + call mw_close (mwin) + call sk_close (cooin) + if (mwout != NULL) + call mw_close (mwout) + call sk_ctypeim (cooout, im) + call sk_close (cooout) + call imunmap (im) + } + + call imtclose (imlist) + + call sfree (sp) +end + + +# RG_WCSSHOW -- Print a quick summary of the current wcs. + +procedure rg_wcsshow (mwin, label, ltv, ltm, w, r, cd, ndim, longpole, latpole) + +pointer mwin #I pointer to the current wcs +char label[ARB] #I name of the input label +double ltv[ARB] #I the lterm offsets +double ltm[ndim,ARB] #I the lterm rotation matrix +double w[ARB] #I the fits crval parameters +double r[ARB] #I the fits crpix parameters +double cd[ndim,ARB] #I the fits rotation matrix +int ndim #I the dimension of the wcs +double longpole #I the longpole value assumed +double latpole #I the latpole value assumed + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("%s wcs\n") + call pargstr (label) + + # Print the axis banner. + call printf (" Axis ") + do i = 1, ndim { + call printf ("%10d ") + call pargi (i) + } + call printf ("\n") + + # Print the crval parameters. + call printf (" Crval ") + do i = 1, ndim { + call printf ("%10.4f ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + call printf (" Crpix ") + do i = 1, ndim { + call printf ("%10.2f ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + do i = 1, ndim { + call printf (" Cd %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%10.4g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print longpole / latpole + call printf (" Poles ") + call printf ("%10.4f %10.4f\n") + call pargd (longpole) + call pargd (latpole) + + call printf ("\n") + + call sfree (sp) +end + + +# RG_LONGPOLE -- Compute the value of longpole and latpole required to +# transform the input celestial coordinate system to the output celestial +# coordinate system, and determine whether this mode of transformation +# is required for the specified projection. + +bool procedure rg_longpole (mwin, incoo, outcoo, ilng, ilat, ilngpole, + ilatpole, olngpole, olatpole) + +pointer mwin #I the input image coordinate system descriptor +pointer incoo #I the input celestial coordinate system descriptor +pointer outcoo #I the output celestial coordinate system descriptor +double ilng #I the input celestial ra / longitude coordinate (deg) +double ilat #I the input celestial dec / latitude coordinate (deg) +double ilngpole #O the input system longpole value (deg) +double ilatpole #O the input system latpole value (deg) +double olngpole #O the output system longpole value (deg) +double olatpole #O the output system latpole value (deg) + +double tilngpole, tilatpole, thetaa, theta0, tilng, tilat, tilngp, tilatp +double ntilng, ntilat +pointer sp, str +int i, projection, ptype +bool usecd +int sk_stati(), rg_wrdstr(), strdic(), ctod() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the projection type + projection = sk_stati (incoo, S_WTYPE) + if (projection <= 0) + projection = WTYPE_LIN + if (rg_wrdstr (projection, Memc[str], SZ_FNAME, + PTYPE_LIST) != projection) + call strcpy ("z", Memc[str], SZ_FNAME) + ptype = strdic (Memc[str], Memc[str], SZ_FNAME, PTYPE_NAMES) + if (ptype <= 0) + ptype = PTYPE_ZEN + + # Get the input value of longpole if any. + iferr { + call mw_gwattrs (mwin, 1, "longpole", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "longpole", Memc[str], SZ_LINE) + } then { + tilngpole = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, tilngpole) <= 0) + tilngpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, tilngpole) <= 0) + tilngpole = INDEFD + } + ilngpole = tilngpole + + # Get the input value of latpole if any. + iferr { + call mw_gwattrs (mwin, 1, "latpole", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "latpole", Memc[str], SZ_LINE) + } then { + tilatpole = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, tilatpole) <= 0) + tilatpole = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, tilatpole) <= 0) + tilatpole = INDEFD + } + ilatpole = tilatpole + + # Get the input value of thetaa if any. + iferr { + call mw_gwattrs (mwin, 1, "projp1", Memc[str], SZ_LINE) + } then { + iferr { + call mw_gwattrs (mwin, 2, "projp1", Memc[str], SZ_LINE) + } then { + thetaa = INDEFD + } else { + i = 1 + if (ctod (Memc[str], i, thetaa) <= 0) + thetaa = INDEFD + } + } else { + i = 1 + if (ctod (Memc[str], i, thetaa) <= 0) + thetaa = INDEFD + } + + # Determine theta0. + switch (ptype) { + case PTYPE_ZEN: + theta0 = DHALFPI + usecd = true + case PTYPE_CYL: + theta0 = 0.0d0 + usecd = false + case PTYPE_CON: + if (IS_INDEFD(thetaa)) + call error (0, "Invalid conic projection parameter thetaa") + else + theta0 = DDEGTORAD(thetaa) + usecd = false + case PTYPE_EXP: + theta0 = DHALFPI + usecd = false + #usecd = true + } + + # Convert the input coordinates to radians. + tilng = DDEGTORAD (ilng) + tilat = DDEGTORAD (ilat) + + # Determine the appropriate value of longpole and convert to radians. + if (IS_INDEFD(tilngpole)) { + if (tilat < theta0) + tilngpole = DPI + else + tilngpole = 0.0d0 + } else + tilngpole = DDEGTORAD (tilngpole) + if (! IS_INDEFD(tilatpole)) + tilatpole = DDEGTORAD (tilatpole) + + # Compute the celestial coordinates of the pole in the old system + # and latpole. + switch (ptype) { + case PTYPE_ZEN, PTYPE_EXP: + tilngp = tilng + tilatp = DHALFPI - tilat + default: + call rg_cnpole (tilng, tilat, theta0, tilngpole, tilatpole, + tilngp, tilatp) + } + #call eprintf ("%0.5f %0.5f %0.5f %0.5f %0.5f %0.5f %0.5f\n") + #call pargd (DRADTODEG(tilng)) + #call pargd (DRADTODEG(tilat)) + #call pargd (DRADTODEG(theta0)) + #call pargd (DRADTODEG(tilngpole)) + #if (IS_INDEFD(tilatpole)) + #call pargd (INDEFD) + #else + #call pargd (DRADTODEG(tilatpole)) + #call pargd (DRADTODEG(tilngp)) + #call pargd (DRADTODEG(tilatp)) + + # Compute the celestial coordinates in the old celestial coordinate + # system of the pole of the new coordinate system. Note that + # because the original coordinate system is a sky coordinate + # system that the input and output coordinate units are degrees. + + call rg_lltransform (outcoo, incoo, 0.0d0, 90.0d0, ntilng, ntilat, 1) + #call eprintf ("%0.5f %0.5f\n") + #call pargd (ntilng) + #call pargd (ntilat) + + # Compute the new longpole and latpole. + call rg_celtonat (DDEGTORAD(ntilng), DDEGTORAD(ntilat), tilngp, tilatp, + tilngpole, olngpole, olatpole) + olngpole = DRADTODEG(olngpole) + olatpole = DRADTODEG(olatpole) + + call sfree (sp) + + return (usecd) +end + + +# RG_CNPOLE -- Give the celestial coordinates of the reference point, the +# native latitude of the reference point, and the native longitude +# of the celestial pole, compute the celestial coordinates of the native +# pole. + +procedure rg_cnpole (ra, dec, theta0, longp, latp, rap, decp) + +double ra #I the reference point ra / longitude in radians +double dec #I the reference point dec / latitude in radians +double theta0 #I the native latitude of the reference point in radians +double longp #I the native longpole of the celestial pole in radians +double latp #I the native latitude of the celestial pole in radians +double rap #O the ra of native pole in radians (Euler angle 1) +double decp #O the codec of native pole in radians (Euler angle 2) + +double clat0, slat0, cphip, sphip, cthe0, sthe0, x, y, z, u, v, latp1, latp2 +double tol, maxlat, tlatp +data tol /1.0d-10/ + +begin + clat0 = cos (dec) + slat0 = sin (dec) + cphip = cos (longp) + sphip = sin (longp) + cthe0 = cos (theta0) + sthe0 = sin (theta0) + x = cthe0 * cphip + y = sthe0 + z = sqrt (x * x + y * y) + + if (z == 0.0d0) { + + if (slat0 != 0.0d0) + call error (0, "Invalid projection parameters") + + if (IS_INDEFD(latp)) + call error (0, "Undefined latpole value") + + tlatp = latp + + } else { + + if (abs (slat0 / z) > 1.0d0) + call error (0, "Invalid projection parameters") + + u = atan2 (y, x) + v = acos (slat0 / z) + + latp1 = u + v + if (latp1 > DPI) + latp1 = latp1 - DTWOPI + else if (latp1 < -DPI) + latp1 = latp1 + DTWOPI + + latp2 = u - v + if (latp2 > DPI) + latp2 = latp2 - DTWOPI + else if (latp2 < -DPI) + latp2 = latp2 + DTWOPI + + if (IS_INDEFD(latp)) + maxlat = 999.0d0 + else + maxlat = latp + if (abs(maxlat - latp1) < abs(maxlat - latp2)) { + if (abs(latp1) < (DHALFPI + tol)) + tlatp = latp1 + else + tlatp = latp2 + } else { + if (abs(latp2) < (DHALFPI + tol)) + tlatp = latp2 + else + tlatp = latp1 + } + } + decp = DHALFPI - tlatp + + # Determine the celestial longitude of the native pole. + z = cos (tlatp) * clat0 + if (abs(z) < tol) { + if (abs(clat0) < tol) { + rap = ra + decp = DHALFPI - theta0 + } else if (tlatp > 0.0d0) { + rap = ra + longp - DPI + decp = 0.0d0 + } else if (tlatp < 0.0d0) { + rap = ra - longp + decp = DPI + } + } else { + x = (sthe0 - sin (tlatp) * slat0) / z + y = sphip * cthe0 / clat0 + if (x == 0.0d0 && y == 0.0d0) + call error (0, "Invalid projection parameters") + rap = ra - atan2 (y,x) + } + if (ra >= 0.0d0) { + if (rap < 0.0d0) + rap = rap + DTWOPI + } else { + if (rap > 0.0d0) + rap = rap - DTWOPI + } +end + + +# RG_CELTONAT - Convert celestial to native coordinates given the input Euler +# angles coordinates of the native pole and the longitude of the celestial pole. + +procedure rg_celtonat (ra, dec, rap, decp, longpole, phi, theta) + +double ra #I input ra/longitude +double dec #I input ra/longitude +double rap #I input euler angle 1 (rap) +double decp #I input euler angle 2 (90-latp) +double longpole #I input euler angle 3 (longpole) +double phi #O output phi +double theta #O output theta + +double x, y, z, dphi + +begin + x = sin (dec) * sin (decp) - cos (dec) * cos (decp) * cos (ra - rap) + if (abs(x) < 1.0d-5) + x = -cos (dec + decp) + cos (dec) * cos(decp) * (1.0d0 - + cos (ra - rap)) + y = -cos (dec) * sin (ra - rap) + if (x != 0.0d0 || y != 0.0d0) + dphi = atan2 (y,x) + else + dphi = ra - rap - DPI + phi = longpole + dphi + if (phi > DPI) + phi = phi - DTWOPI + else if (phi < -DPI) + phi = phi + DTWOPI + if (mod (ra - rap, DPI) == 0.0d0) { + theta = dec + cos (ra - rap) * decp + if (theta > DHALFPI) + theta = DPI - theta + if (theta < -DHALFPI) + theta = -DPI - theta + } else { + z = sin (dec) * cos (decp) + cos (dec) * sin(decp) * cos (ra - rap) + if (abs(z) > 0.99d0) + theta = sign (acos(sqrt (x*x + y*y)), z) + else + theta = asin (z) + } +end + + +# RG_CDFIT -- Compute the cd matrix and shift vector required to realign +# the transformed coordinate systems. + +int procedure rg_cdfit (xref, yref, xin, yin, npts, xscale, yscale, xrot, yrot) + +double xref[ARB] #I the input x reference vector +double yref[ARB] #I the input y reference vector +double xin[ARB] #I the input x vector +double yin[ARB] #I the input y vector +int npts #I the number of points +double xscale, yscale #O the x and y scale factors +double xrot #O the rotation angle in degrees +double yrot #O the rotation angle in degrees + +int fitstat +double xshift, yshift +pointer sp, wts +int rg_ffit() + +begin + call smark (sp) + call salloc (wts, npts, TY_DOUBLE) + call amovkd (1.0d0, Memd[wts], npts) + + fitstat = rg_ffit (xref, yref, xin, yin, Memd[wts], npts, + xshift, yshift, xscale, yscale, xrot, yrot) + if (fitstat == ERR) { + xrot = INDEFD + yrot = INDEFD + xscale = INDEFD + yscale = INDEFD + } + + call sfree (sp) + return (fitstat) +end + + +# RG_FFIT -- Compute the x and y shift, th x and y scale, and the x and y +# rotation angle required to match one set of coordinates to another. + +int procedure rg_ffit (xref, yref, xin, yin, wts, npts, xshift, yshift, + xmag, ymag, xrot, yrot) + +double xref[ARB] #I reference image x values +double yref[ARB] #I reference image y values +double xin[ARB] #I input image x values +double yin[ARB] #I input image y values +double wts[ARB] #I array of weights +int npts #I number of points +double xshift, yshift #O the x and y shifts +double xmag, ymag #O the x and y scale factors +double xrot, yrot #O the rotation angles + +double xmin, xmax, ymin, ymax +int xier, yier, ier +pointer sx1, sy1 + +begin + # Compute the data limits. + call alimd (xref, npts, xmin, xmax) + call alimd (yref, npts, ymin, ymax) + + # Compute the x fit. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sx1, xref, yref, xin, wts, npts, WTS_USER, xier) + + # Compute the y fit. + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sy1, xref, yref, yin, wts, npts, WTS_USER, yier) + + # Compute the geometric parameters. + if (xier != OK || yier != OK) { + xshift = INDEFD + yshift = INDEFD + xmag = INDEFD + ymag = INDEFD + xrot = INDEFD + yrot = INDEFD + ier = ERR + } else { + call geo_lcoeffd (sx1, sy1, xshift, yshift, xmag, ymag, xrot, yrot) + ier = OK + } + + call dgsfree (sx1) + call dgsfree (sy1) + return (ier) +end + + +define CDIN icd[$1,$2] +define CDOUT ocd[$1,$2] + +# RG_MWXYROT -- Scale and rotate the CD matrix by specifying the x and y scale +# factors in dimensionless units and the rotation angle in degrees. Since only +# x and y scale factors and one rotation angle can be specified, this routine +# is useful only useful for a 2D transformation + +procedure rg_mwxyrot(mw, xmag, ymag, xtheta, ytheta, icd, ocd, ndim, axbits) + +pointer mw #I pointer to MWCS descriptor +double xmag, ymag #I the x and y scaling factors +double xtheta #I the x rotation angle, degrees +double ytheta #I the y rotation angle, degrees +double icd[ndim,ARB] #U the input CD matrix +double ocd[ndim,ARB] #U the output CD matrix +int ndim #I dimensions of the CD matrix +int axbits #I bitflags defining axes to be rotated + +double d_thetax, d_thetay, costx, sintx, costy, sinty +int axis[IM_MAXDIM], naxes, ax1, ax2, axmap +int mw_stati() +errchk syserr + +begin + # Convert axis bitflags to axis list and get the two axes. + call mw_gaxlist (mw, axbits, axis, naxes) + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + ax1 = axis[1] + ax2 = axis[2] + + # Rotate the CD matrix. + d_thetax = DEGTORAD(xtheta) + d_thetay = DEGTORAD(ytheta) + costx = cos (d_thetax) + sintx = sin (d_thetax) + costy = cos (d_thetay) + sinty = sin (d_thetay) + call amovd (icd, ocd, ndim * ndim) + + CDOUT(ax1,ax1) = xmag * costx * CDIN(ax1,ax1) - + xmag * sintx * CDIN(ax2,ax1) + CDOUT(ax2,ax1) = ymag * sinty * CDIN(ax1,ax1) + + ymag * costy * CDIN(ax2,ax1) + CDOUT(ax1,ax2) = xmag * costx * CDIN(ax1,ax2) - + xmag * sintx * CDIN(ax2,ax2) + CDOUT(ax2,ax2) = ymag * sinty * CDIN(ax1,ax2) + + ymag * costy * CDIN(ax2,ax2) + + call mw_seti (mw, MW_USEAXMAP, axmap) +end + + +# RG_RMSDIFF -- Compute the standard deviation of the difference between 2 +# vectors + +double procedure rg_rmsdiff (a, b, npts) + +double a[ARB] #I the first input vector +double b[ARB] #I the second input vector +int npts #I the number of points + +int i +double sum, rms + +begin + sum = 0.0d0 + do i = 1, npts + sum = sum + (a[i] - b[i]) ** 2 + + if (npts <= 1) + rms = INDEFD + else + rms = sqrt (sum / (npts - 1)) + + return (rms) +end + diff --git a/pkg/images/imcoords/src/t_skyctran.x b/pkg/images/imcoords/src/t_skyctran.x new file mode 100644 index 00000000..05a7e824 --- /dev/null +++ b/pkg/images/imcoords/src/t_skyctran.x @@ -0,0 +1,221 @@ +include +include + +procedure t_skyctran() + +bool verbose, transform, first_file +int inlist, outlist, linlist, loutlist, lngcolumn, latcolumn, infd, outfd +int ilngunits, ilatunits, olngunits, olatunits, min_sigdigits, optype +int instat, outstat, nilng, nilat, plngcolumn, platcolumn, pxcolumn +int rvcolumn +double ilngmin, ilngmax, ilatmin, ilatmax +int fstati() +pointer sp, inname, outname, insystem, outsystem, olngformat, olatformat +pointer ilngformat, ilatformat, str, mwin, mwout, cooin, cooout + +bool clgetb(), streq() +double clgetd() +int clpopnu(), clplen(), clgfil(), open(), sk_decwcs() +int clgeti(), clgwrd(), sk_stati() +errchk clgwrd() + +begin + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (insystem, SZ_FNAME, TY_CHAR) + call salloc (outsystem, SZ_FNAME, TY_CHAR) + call salloc (ilngformat, SZ_FNAME, TY_CHAR) + call salloc (ilatformat, SZ_FNAME, TY_CHAR) + call salloc (olngformat, SZ_FNAME, TY_CHAR) + call salloc (olatformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Open the input and output file lists. + inlist = clpopnu ("input") + linlist = clplen (inlist) + outlist = clpopnu ("output") + loutlist = clplen (outlist) + call clgstr ("insystem", Memc[insystem], SZ_FNAME) + call clgstr ("outsystem", Memc[outsystem], SZ_FNAME) + transform = clgetb ("transform") + + # Fetch the file formatting parameters. + lngcolumn = clgeti ("lngcolumn") + latcolumn = clgeti ("latcolumn") + plngcolumn = clgeti ("plngcolumn") + platcolumn = clgeti ("platcolumn") + pxcolumn = clgeti ("pxcolumn") + rvcolumn = clgeti ("rvcolumn") + ilngmin = clgetd ("ilngmin") + ilngmax = clgetd ("ilngmax") + ilatmin = clgetd ("ilatmin") + ilatmax = clgetd ("ilatmax") + nilng = clgeti ("nilng") + nilat = clgeti ("nilat") + iferr (ilngunits = clgwrd ("ilngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + ilngunits = 0 + iferr (ilatunits = clgwrd ("ilatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + ilatunits = 0 + call clgstr ("ilngformat", Memc[ilngformat], SZ_FNAME) + call clgstr ("ilatformat", Memc[ilatformat], SZ_FNAME) + + iferr (olngunits = clgwrd ("olngunits", Memc[str], SZ_FNAME, + SKY_LNG_UNITLIST)) + olngunits = 0 + iferr (olatunits = clgwrd ("olatunits", Memc[str], SZ_FNAME, + SKY_LAT_UNITLIST)) + olatunits = 0 + call clgstr ("olngformat", Memc[olngformat], SZ_FNAME) + call clgstr ("olatformat", Memc[olatformat], SZ_FNAME) + #min_sigdigits = clgeti ("min_sigdigits") + min_sigdigits = 7 + verbose = clgetb ("verbose") + + # Test the length of the input coordinate list. + if (linlist < 1) + call error (0, "The input coordinate file list is empty") + if (loutlist < 1) + call error (0, "The output coordinate file list is empty") + if (loutlist > 1 && loutlist != linlist) + call error (0, + "The number of input and output files are not the same") + + # Determine the input coordinate system. + instat = sk_decwcs (Memc[insystem], mwin, cooin, NULL) + + # Determine the output coordinate system. + outstat = sk_decwcs (Memc[outsystem], mwout, cooout, NULL) + + # Loop over the input files. + first_file = true + while (clgfil (inlist, Memc[inname], SZ_FNAME) != EOF) { + + # Open the input coordinate file. The string "imcursor" is + # reserved for the image display cursor. + if (streq (Memc[inname], "imcursor") && mwin != NULL) { + infd = NULL + optype = sk_stati (cooin, S_PIXTYPE) + call sk_seti (cooin, S_PIXTYPE, PIXTYPE_TV) + } else if (streq (Memc[inname], "grid")) { + optype = sk_stati (cooin, S_PIXTYPE) + infd = NULL + } else + infd = open (Memc[inname], READ_ONLY, TEXT_FILE) + + # Open the output coordinate file. + if (clgfil (outlist, Memc[outname], SZ_FNAME) != EOF) { + outfd = open (Memc[outname], NEW_FILE, TEXT_FILE) + if (streq (Memc[outname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + call fprintf (outfd, "\n") + if (instat == ERR) + call fprintf (outfd, + "# Error decoding the input coordinate system\n") + call sk_iiwrite (outfd, "Insystem", Memc[insystem], mwin, + cooin) + if (outstat == ERR) + call fprintf (outfd, + "# Error decoding the output coordinate system\n") + call sk_iiwrite (outfd, "Outsystem", Memc[outsystem], mwout, + cooout) + } + + # Print information about the input and output coordinate system + # and the input and output files to the standard output. + if (verbose && outfd != STDOUT) { + if (first_file) { + call printf ("\n") + if (instat == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[insystem], mwin, cooin) + if (outstat == ERR) + call printf ( + "Error decoding the output coordinate system\n") + call sk_iiprint ("Outsystem", Memc[outsystem], mwout, + cooout) + call printf ("\n") + } + call printf ("Input file: %s Output file: %s\n") + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call flush (STDOUT) + } + + + # Print the input and output file name banner. + call fprintf (outfd, "\n# Input file: %s Output file: %s\n") + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call fprintf (outfd, "\n") + + # Transform the coordinate list. + if (infd == NULL) { + if (streq ("imcursor", Memc[inname])) + call sk_curtran (outfd, mwin, mwout, cooin, cooout, + olngunits, olatunits, Memc[olngformat], + Memc[olatformat], transform) + else if (instat == ERR || outstat == ERR) + call sk_grcopy (outfd, cooin, cooout, ilngmin, ilngmax, + nilng, ilatmin, ilatmax, nilat, ilngunits, + ilatunits, olngunits, olatunits, Memc[ilngformat], + Memc[ilatformat], Memc[olngformat], + Memc[olatformat], transform) + else + call sk_grtran (outfd, mwin, mwout, cooin, cooout, + ilngmin, ilngmax, nilng, ilatmin, ilatmax, nilat, + ilngunits, ilatunits, olngunits, olatunits, + Memc[ilngformat], Memc[ilatformat], Memc[olngformat], + Memc[olatformat], transform) + } else { + if (infd == STDIN && fstati(STDIN, F_REDIR) == NO) + call sk_ttytran (infd, outfd, mwin, mwout, cooin, cooout, + ilngunits, ilatunits, olngunits, olatunits, + Memc[olngformat], Memc[olatformat]) + else if (instat == ERR || outstat == ERR) + call sk_copytran (infd, outfd, lngcolumn, latcolumn, + transform) + else + call sk_listran (infd, outfd, mwin, mwout, cooin, cooout, + lngcolumn, latcolumn, plngcolumn, platcolumn, + pxcolumn, rvcolumn, ilngunits, ilatunits, olngunits, + olatunits, Memc[olngformat], Memc[olatformat], + min_sigdigits, transform) + } + + # Close the output coordinate file. + if (linlist == loutlist) + call close (outfd) + + # Close the input coordinate file. + if (infd != NULL) + call close (infd) + else + call sk_seti (cooin, S_PIXTYPE, optype) + + first_file = false + } + + # Close the image wcs if one was opened. + if (loutlist < linlist) + call close (outfd) + if (mwin != NULL) + call mw_close (mwin) + if (mwout != NULL) + call mw_close (mwout) + #call mfree (cooin, TY_STRUCT) + call sk_close (cooin) + #call mfree (cooout, TY_STRUCT) + call sk_close (cooout) + + # Close up the lists. + call clpcls (inlist) + call clpcls (outlist) + + call sfree (sp) +end + + diff --git a/pkg/images/imcoords/src/t_starfind.x b/pkg/images/imcoords/src/t_starfind.x new file mode 100644 index 00000000..6288ea15 --- /dev/null +++ b/pkg/images/imcoords/src/t_starfind.x @@ -0,0 +1,224 @@ +include + +# T_STARFIND -- Automatically detect objects in an image given the full- +# width half-maximum of the image point spread function and a detection +# threshold using a modified version of the daofind algorithm. + +procedure t_starfind () + +int imlist, olist, limlist, lolist, boundary, verbose +int stat, root, out, nxblock, nyblock +pointer sp, image, output, outfname, str, wcs, wxformat, wyformat +pointer im, sf +real constant + +bool clgetb() +int imtopenp(), clpopnu(), imtlen(), clplen(), clgwrd(), btoi(), open() +int clgeti(), imtgetim(), clgfil(), fnldir(), strncmp(), strlen() +pointer immap() +real clgetr() + +begin + # Flush STDOUT on a new line. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (outfname, SZ_FNAME, TY_CHAR) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (wxformat, SZ_FNAME, TY_CHAR) + call salloc (wyformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the image and output file lists. + imlist = imtopenp ("image") + limlist = imtlen (imlist) + olist = clpopnu ("output") + lolist = clplen (olist) + + # Test the input and output file list. + if (lolist > 1 && lolist != limlist) { + call imtclose (imlist) + call clpcls (olist) + call sfree (sp) + call error (0, "Imcompatible image and output list lengths") + } + + # Get the algorithm parameters. + call sf_gpars (sf) + + # Get the wcs paramaters. + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + call clgstr ("wxformat", Memc[wxformat], SZ_FNAME) + call clgstr ("wyformat", Memc[wyformat], SZ_FNAME) + + # Get the image blocking boundary extensions parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + nxblock = clgeti ("nxblock") + nyblock = clgeti ("nyblock") + + # Verbose mode ? + verbose = btoi (clgetb ("verbose")) + + # Loop over the images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + + # Get the output file name and open the file. + if (lolist == 0) { + call strcpy ("", Memc[outfname], SZ_FNAME) + out = NULL + } else { + stat = clgfil (olist, Memc[output], SZ_FNAME) + root = fnldir (Memc[output], Memc[outfname], SZ_FNAME) + if (strncmp ("default", Memc[output+root], 7) == 0 || root == + strlen (Memc[output])) { + call sf_outname (Memc[image], Memc[outfname], "obj", + Memc[outfname], SZ_FNAME) + lolist = limlist + } else if (stat != EOF) { + call strcpy (Memc[output], Memc[outfname], SZ_FNAME) + } else { + call sf_outname (Memc[image], Memc[outfname], "obj", + Memc[outfname], SZ_FNAME) + lolist = limlist + } + } + out = open (Memc[outfname], NEW_FILE, TEXT_FILE) + + # Find the stars in an image. + call sf_find (im, out, sf, nxblock, nyblock, Memc[wcs], + Memc[wxformat], Memc[wyformat], boundary, constant, + verbose) + + # Close images and files. + call imunmap (im) + call close (out) + + } + + + # Close lists. + call sf_free (sf) + call imtclose (imlist) + call clpcls (olist) + call sfree (sp) +end + + +# SF_OUTNAME -- Construct the output file name. If output is null or a +# directory, a name is constructed from the root of the image name and +# the extension. The disk is searched to avoid name collisions. + +procedure sf_outname (image, output, ext, name, maxch) + +char image[ARB] #I image name +char output[ARB] #I output directory or name +char ext[ARB] #I extension +char name[ARB] #O output name +int maxch #I maximum size of name + +int ndir, nimdir, clindex, clsize +pointer sp, root, str +int fnldir(), strlen() + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + ndir = fnldir (output, name, maxch) + if (strlen (output) == ndir) { + call imparse (image, Memc[root], SZ_FNAME, Memc[str], SZ_FNAME, + Memc[str], SZ_FNAME, clindex, clsize) + nimdir = fnldir (Memc[root], Memc[str], SZ_FNAME) + if (clindex >= 0) { + call sprintf (name[ndir+1], maxch, "%s%d.%s.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + call pargstr (ext) + } else { + call sprintf (name[ndir+1], maxch, "%s.%s.*") + call pargstr (Memc[root+nimdir]) + call pargstr (ext) + } + call sf_oversion (name, name, maxch) + } else + call strcpy (output, name, maxch) + + call sfree (sp) +end + + +## SF_IMROOT -- Fetch the root image name minus the directory specification +## and the section notation. The length of the root name is returned. +# +#int procedure sf_imroot (image, root, maxch) +# +#char image[ARB] #I image specification +#char root[ARB] #O rootname +#int maxch #I maximum number of characters +# +#int nchars +#pointer sp, str +#int fnldir(), strlen() +# +#begin +# call smark (sp) +# call salloc (str, SZ_FNAME, TY_CHAR) +# +# call imgimage (image, root, maxch) +# nchars = fnldir (root, Memc[str], maxch) +# call strcpy (root[nchars+1], root, maxch) +# +# call sfree (sp) +# return (strlen (root)) +#end + + +# SF_OVERSION -- Compute the next available version number of a given file +# name template and output the new file name. + +procedure sf_oversion (template, filename, maxch) + +char template[ARB] #I name template +char filename[ARB] #O output name +int maxch #I maximum number of characters + +char period +int newversion, version, len +pointer sp, list, name +int fntgfnb() strldx(), ctoi(), fntopnb() + +begin + # Allocate temporary space + call smark (sp) + call salloc (name, maxch, TY_CHAR) + period = '.' + list = fntopnb (template, NO) + + # Loop over the names in the list searchng for the highest version. + newversion = 0 + while (fntgfnb (list, Memc[name], maxch) != EOF) { + len = strldx (period, Memc[name]) + len = len + 1 + if (ctoi (Memc[name], len, version) <= 0) + next + newversion = max (newversion, version) + } + + # Make new output file name. + len = strldx (period, template) + call strcpy (template, filename, len) + call sprintf (filename[len+1], maxch, "%d") + call pargi (newversion + 1) + + call fntclsb (list) + call sfree (sp) +end diff --git a/pkg/images/imcoords/src/t_wcsctran.x b/pkg/images/imcoords/src/t_wcsctran.x new file mode 100644 index 00000000..7459ec48 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsctran.x @@ -0,0 +1,643 @@ +include +include +include +include +include +include + +# Define some limits on the input file + +define MAX_FIELDS 100 # maximum number of fields in the list +define TABSIZE 8 # spacing of the tab stops + +# Define the supported units + +define WT_UNITSTR "|hours|native|" +define WT_UHOURS 1 +define WT_UNATIVE 2 + +define WT_WCSSTR "|logical|tv|physical|world|" +define WT_LOGICAL 1 +define WT_TV 2 +define WT_PHYSICAL 3 +define WT_WORLD 4 + +# Define the supported wcs. +# T_WCSCTRAN -- Transform a list of image coordinates from one coordinate +# system to another using world coordinate system information stored in +# the header of a reference image. + +procedure t_wcsctran() + +bool verbose +int i, csp, imlist,inlist, outlist, limlist, linlist, loutlist +int icl, ocl, ndim, wcsndim, ncolumns, nunits, inwcs, outwcs, min_sigdigits +pointer sp, image, columns, units, iwcs, owcs, fmtstr, fmtptrs +pointer str, name, im, mw, ct, tmp + +bool clgetb() +int imtopenp(), imtlen(), imtgetim(), fntopnb(), fntlenb(), fntgfnb() +int open(), mw_stati(), wt_getlabels(), ctoi(), strdic(), clgeti(), nscan() +int errget() +pointer immap(), mw_openim(), mw_sctran() +errchk mw_openim(), mw_gwattrs(), mw_sctran() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (columns, IM_MAXDIM, TY_INT) + call salloc (units, IM_MAXDIM, TY_INT) + call salloc (iwcs, SZ_FNAME, TY_CHAR) + call salloc (owcs, SZ_FNAME, TY_CHAR) + call salloc (fmtstr, SZ_FNAME, TY_CHAR) + call salloc (fmtptrs, IM_MAXDIM, TY_POINTER) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_FNAME, TY_CHAR) + + # Get the input and output image and file lists. + imlist = imtopenp ("image") + limlist = imtlen (imlist) + call clgstr ("input", Memc[str], SZ_FNAME) + inlist = fntopnb (Memc[str], NO) + linlist = fntlenb (inlist) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + loutlist = fntlenb (outlist) + + # Get the input coordinate file format. + call clgstr ("columns", Memc[str], SZ_FNAME) + ncolumns = 0 + csp = 1 + while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) { + i = 1 + if (ctoi(Memc[name], i, Memi[columns+ncolumns]) <= 0) + break + ncolumns = ncolumns + 1 + } + + # Get the input coordinate units. Fill in any missing information + # with native units + call clgstr ("units", Memc[str], SZ_FNAME) + nunits = 0 + csp = 1 + while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) { + i = strdic (Memc[name], Memc[name], SZ_FNAME, WT_UNITSTR) + if (i <= 0) + break + Memi[units+nunits] = i + nunits = nunits + 1 + } + do i = nunits + 1, IM_MAXDIM + Memi[units+i-1] = WT_UNATIVE + + # Get the input and output transform. + call clgstr ("inwcs", Memc[iwcs], SZ_FNAME) + inwcs = strdic (Memc[iwcs], Memc[iwcs], SZ_FNAME, WT_WCSSTR) + call clgstr ("outwcs", Memc[owcs], SZ_FNAME) + outwcs = strdic (Memc[owcs], Memc[owcs], SZ_FNAME, WT_WCSSTR) + + # Get the format strings and minimum number of significant digits. + call clgstr ("formats", Memc[fmtstr], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the remaining parameters. + verbose = clgetb ("verbose") + + # Check that the image and output list lengths match. The number + # of input coordinate lists must be 1 or equal to the number of + # input images. + if (limlist < 1 || (linlist > 1 && linlist != limlist)) { + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + call error (0, + "Incompatable image and input coordinate list lengths.") + } + + # Check that the image and output list lengths match. The number + # of output coordinate lists must be 1 or equal to the number of + # input images. + if (loutlist > 1 && loutlist != limlist) { + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + call error (0, + "Incompatable image and output coordinate list lengths.") + } + + # Loop over the input images. + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + ndim = IM_NDIM(im) + + # Open the input coordinate file. + if (linlist <= 0) + icl = NULL + else if (fntgfnb (inlist, Memc[str], SZ_FNAME) != EOF) + icl = open (Memc[str], READ_ONLY, TEXT_FILE) + else + call seek (icl, BOF) + + # Open the output coordinate file. + if (fntgfnb (outlist, Memc[str], SZ_FNAME) != EOF) { + ocl = open (Memc[str], NEW_FILE, TEXT_FILE) + if (ocl == STDOUT) + call fseti (ocl, F_FLUSHNL, YES) + } + + # Print optional banner string. + if (verbose) { + call fprintf (ocl, "\n# Image: %s Wcsin: %s Wcsout: %s\n") + call pargstr (Memc[image]) + call pargstr (Memc[iwcs]) + call pargstr (Memc[owcs]) + } + + # Set up the coordinate transform. + mw = NULL + iferr { + + tmp = mw_openim (im); mw = tmp + + call mw_seti (mw, MW_USEAXMAP, NO) + if (inwcs == WT_TV && outwcs == WT_TV) + ct = mw_sctran (mw, "logical", "logical", 0) + else if (inwcs == WT_TV) + ct = mw_sctran (mw, "logical", Memc[owcs], 0) + else if (outwcs == WT_TV) + ct = mw_sctran (mw, Memc[iwcs], "logical", 0) + else + ct = mw_sctran (mw, Memc[iwcs], Memc[owcs], 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + if (ndim == 0) + ndim = wcsndim + + call sscan (Memc[fmtstr]) + do i = 1, IM_MAXDIM { + call malloc (Memi[fmtptrs+i-1], SZ_FNAME, TY_CHAR) + call gargwrd (Memc[Memi[fmtptrs+i-1]], SZ_FNAME) + if (nscan() != i || Memc[Memi[fmtptrs+i-1]] == EOS) { + if (outwcs == WT_WORLD) { + iferr (call mw_gwattrs (mw, i, "format", + Memc[Memi[fmtptrs+i-1]], SZ_FNAME)) + Memc[Memi[fmtptrs+i-1]] = EOS + } else + Memc[Memi[fmtptrs+i-1]] = EOS + } + } + + } then { + if (verbose) { + i = errget (Memc[str], SZ_LINE) + call fprintf (ocl, "# \tWarning: %s\n") + call pargstr (Memc[str]) + } + if (mw != NULL) + call mw_close (mw) + mw = NULL + ct = NULL + } + + # Check that the transform is valid. + if (ct == NULL) { + + # Skip the image if the transform is undefined. + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Unable to compile requested transform\n") + } + + # For input or output tv coordinates the image must be 2D + } else if (ndim != 2 && (inwcs == WT_TV || outwcs == WT_TV)) { + + # Skip the image if the transform is undefined. + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Image must be 2D for wcs type tv\n") + } + + # Check that the number of input columns is enough for images. + } else if ((ncolumns < ndim) || (ncolumns < wcsndim && inwcs != + WT_LOGICAL && inwcs != WT_TV)) { + + if (verbose) { + call fprintf (ocl, + "# \tSkipping: Too few input coordinate columns\n") + } + + } else { + + # Check the dimension of the wcs versus the dimension of the + # image and issue a warning if dimensional reduction has taken + # place. + if (wcsndim > ndim) { + if (verbose) { + call fprintf (ocl, + "# \tWarning: Image has been dimensionally reduced\n") + } + } + if (verbose) { + call fprintf (ocl, "\n") + } + + # Transform the coordinate file. + call wt_transform (im, icl, ocl, Memi[columns], Memi[units], + ndim, inwcs, outwcs, mw, ct, Memi[fmtptrs], wcsndim, + min_sigdigits) + + } + + # Free the format pointers. + do i = 1, IM_MAXDIM + call mfree (Memi[fmtptrs+i-1], TY_CHAR) + + # Close the input image. + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + + # Close the input coordinate file if it is not going to be used. + if (linlist == limlist) + call close (icl) + + # Close the output coordinate file if it is not going to be + # appended to. + if (loutlist == limlist) + call close (ocl) + } + + # Close the input coordinate file + if (linlist > 0 && linlist < limlist) + call close (icl) + if (loutlist < limlist) + call close (ocl) + + call imtclose (imlist) + call fntclsb (inlist) + call fntclsb (outlist) + + call sfree (sp) +end + + +# WT_TRANSFORM -- Transform the input coordinates from the input coordinate +# system to the output coordinate system. + +procedure wt_transform (im, icl, ocl, columns, units, ndim, inwcs, outwcs, mw, + ct, fmtptrs, wcsndim, min_sigdigits) + +pointer im #I the input image descriptor +int icl #I the input coordinate file descriptor +int ocl #I the output coordinate file descriptor +int columns[ARB] #I the input coordinate columns +int units[ARB] #I the input coordinate units +int ndim #I the number of input coordinates +int inwcs #I the input wcs type +int outwcs #I the output wcs type +pointer mw #I the wcs descriptor +pointer ct #I the pointer to the compiled transformation +pointer fmtptrs[ARB] #I the array of format pointers +int wcsndim #I the dimensions of the wcs +int min_sigdigits #I the minimum number of significant digits + +int nline, ip, nread, nwrite, max_fields, nfields, offset +pointer sp, inbuf, linebuf, field_pos, outbuf, voff, vstep, paxno, laxno, incoo +pointer lincoo, outcoo, nsig +int getline(), li_get_numd() + +begin + # Allocate working space. + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + + call salloc (voff, wcsndim, TY_DOUBLE) + call salloc (vstep, wcsndim, TY_DOUBLE) + call salloc (paxno, wcsndim, TY_INT) + call salloc (laxno, wcsndim, TY_INT) + call salloc (incoo, wcsndim, TY_DOUBLE) + call salloc (lincoo, wcsndim, TY_DOUBLE) + call salloc (outcoo, wcsndim, TY_DOUBLE) + call salloc (nsig, wcsndim, TY_INT) + + call mw_gaxmap (mw, Memi[paxno], Memi[laxno], wcsndim) + call wt_laxmap (outwcs, Memi[paxno], wcsndim, Memi[laxno], ndim) + call wt_vmap (im, Memd[voff], Memd[vstep], ndim) + + # Compute the number of coordinates to be read and written. + if (inwcs == WT_LOGICAL && ndim < wcsndim) + nread = ndim + else + nread = wcsndim + if (outwcs == WT_LOGICAL && ndim < wcsndim) + nwrite = ndim + else + nwrite = wcsndim + call amovkd (INDEFD, Memd[outcoo], wcsndim) + + max_fields = MAX_FIELDS + for (nline = 1; getline (icl, Memc[inbuf]) != EOF; nline = nline + 1) { + + # Skip over leading white space. + for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1) + ; + + # Pass on comment and blank lines unchanged. + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (ocl, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (ocl, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + # Decode the coordinates checking for valid input. + call aclri (Memi[nsig], wcsndim) + do ip = 1, nread { + + if (columns[ip] > nfields) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tNot enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (ocl, Memc[linebuf]) + break + } + + offset = Memi[field_pos+columns[ip]-1] + if (li_get_numd (Memc[linebuf+offset-1], + Memd[incoo+ip-1], Memi[nsig+ip-1]) == 0) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tBad value in file %s line %d column %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call pargi (ip) + call putline (ocl, Memc[linebuf]) + break + } + + if (IS_INDEFD(Memd[incoo+ip-1])) { + call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("\tBad value in file %s line %d column %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call pargi (ip) + call putline (ocl, Memc[linebuf]) + break + } + + } + + # Skip to next line if too few fields were read. + if (ip <= nread) + next + + # Adjust the input coordinate units if necessary. + switch (inwcs) { + case WT_TV: + call wt_tvlogd (Memd[incoo], Memd[incoo], nread, Memd[voff], + Memd[vstep]) + case WT_WORLD: + call wt_cunits (Memd[incoo], units, nread) + default: + ; + } + + # Compute the transform. + call wt_ctrand (ct, Memd[incoo], Memd[lincoo], Memi[paxno], + Memd[outcoo], wcsndim, nread) + + # Adjust the output coordinate units if necessary. + switch (outwcs) { + case WT_TV: + call wt_logtvd (Memd[outcoo], Memd[outcoo], wcsndim, + Memi[laxno], Memd[voff], Memd[vstep]) + default: + ; + } + + # Create the output file line. + call rg_apack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, columns, nread, Memd[outcoo], + Memi[laxno], fmtptrs, Memi[nsig], nwrite, min_sigdigits) + + # Write out the reformatted output line. + call putline (ocl, Memc[outbuf]) + + } + + call sfree (sp) +end + + +# WT_LAXMAP (paxno, wcsndim, laxno, ndim) + +procedure wt_laxmap (outwcs, paxno, wcsndim, laxno, ndim) + +int outwcs #I the output wcs +int paxno[ARB] #I the physical axis map +int wcsndim #I the number of physical axis dimensions +int laxno[ARB] #O the physical axis map +int ndim #I the number of logical axis dimensions + +int i, j + +begin + if (outwcs == WT_LOGICAL && ndim < wcsndim) { + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + do i = ndim + 1, wcsndim + laxno[i] = 0 + } else { + do i = 1, wcsndim + laxno[i] = i + } +end + + +# WT_VMAP -- Fetch the image i/o section map. Tecnically this routine +# violates a system interface and uses the internal definitions in +# the imio.h file. However this routine is required to support tv coordinates +# which are coordinates with respect to the current section, and not identical +# to physcial coordinates. + +procedure wt_vmap (im, voff, vstep, ndim) + +pointer im #I the input image descriptor +double voff[ARB] #O the array of offsets +double vstep[ARB] #O the array of step sizes +int ndim #I the number of dimensions + +int i, dim + +begin + do i = 1, ndim { + dim = IM_VMAP(im,i) + voff[i] = IM_VOFF(im,dim) + vstep[i] = IM_VSTEP(im,dim) + } +end + + +# WT_UNITS -- Correct the units of the input coordinates if necessary. + +procedure wt_cunits (incoo, units, ncoo) + +double incoo[ARB] #I the array of input coordinates +int units[ARB] #I the array of units +int ncoo #I the number of coordinates + +int i + +begin + do i = 1, ncoo { + switch (units[i]) { + case WT_UHOURS: + incoo[i] = 15.0d0 * incoo[i] + default: + ; + } + } +end + + +# WT_TVLOGD -- Linearly transform a vector of coordinates using an +# array of voffsets and scale factors. + +procedure wt_tvlogd (incoo, outcoo, ndim, voff, vstep) + +double incoo[ARB] #I array of input coordinates +double outcoo[ARB] #O array of output coordinates +int ndim #I number of coordinates +double voff[ARB] #I array of zero points +double vstep[ARB] #I array of scale factors + +int i + +begin + do i = 1, ndim + outcoo[i] = (incoo[i] - voff[i]) / vstep[i] +end + + +# WT_CTRAND -- Transform the coordinates. + +procedure wt_ctrand (ct, incoo, lincoo, paxno, outcoo, wcsndim, nread) + +pointer ct #I pointer to the compiled transform +double incoo[ARB] #I array of input coordinates +double lincoo[ARB] #U scratch array of input coordinates +int paxno[ARB] #I the physical axis map +double outcoo[ARB] #O array of output coordinates +int wcsndim #I the dimension of the wcs +int nread #I the number of input coordinates. + +int i + +begin + if (nread < wcsndim) { + do i = 1, wcsndim { + if (paxno[i] == 0) + lincoo[i] = 1.0d0 + else + lincoo[i] = incoo[paxno[i]] + } + if (ct == NULL) + call amovd (lincoo, outcoo, wcsndim) + else + call mw_ctrand (ct, lincoo, outcoo, wcsndim) + + } else { + if (ct == NULL) + call amovd (incoo, outcoo, wcsndim) + else + call mw_ctrand (ct, incoo, outcoo, wcsndim) + } + +end + + +# WT_LOGTVD -- Linearly transform a vector of coordinates using an +# array of voffsets and scale factors. + +procedure wt_logtvd (incoo, outcoo, wcsndim, laxno, voff, vstep) + +double incoo[ARB] #I array of input coordinates +double outcoo[ARB] #O array of output coordinates +int wcsndim #I number of coordinates +int laxno[ARB] #I the logical axis map +double voff[ARB] #I array of zero points +double vstep[ARB] #I array of scale factors + +int i + +begin + do i = 1, wcsndim { + if (laxno[i] != 0) + outcoo[laxno[i]] = (incoo[laxno[i]] * vstep[laxno[i]]) + + voff[laxno[i]] + } +end + + +# WT_GETLABELS -- Get the next label from a list of labels. + +int procedure wt_getlabels (list, ip, label, maxch) + +char list[ARB] #I list of labels +int ip #U pointer in to the list of labels +char label[ARB] #O the output label +int maxch #I maximum length of a column name + +int op, token +int ctotok(), strlen() + +begin + # Decode the column labels. + op = 1 + while (list[ip] != EOS) { + + token = ctotok (list, ip, label[op], maxch) + if (label[op] == EOS) + next + if ((token == TOK_UNKNOWN) || (token == TOK_CHARCON)) + break + if ((token == TOK_PUNCTUATION) && (label[op] == ',')) { + if (op == 1) + next + else + break + } + + op = op + strlen (label[op]) + break + } + + label[op] = EOS + if ((list[ip] == EOS) && (op == 1)) + return (EOF) + else + return (op - 1) +end + diff --git a/pkg/images/imcoords/src/t_wcsedit.x b/pkg/images/imcoords/src/t_wcsedit.x new file mode 100644 index 00000000..51d44992 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsedit.x @@ -0,0 +1,792 @@ +include +include +include + +define HELPFILE "imcoords$src/wcsedit.key" + +define WCSCMDS ",?,show,update,quit," +define WCS_HELP 1 +define WCS_SHOW 2 +define WCS_UPDATE 3 +define WCS_QUIT 4 + +define WCSPARS ",CRVAL,CRPIX,CD,LTV,LTM,WTYPE,AXTYPE,UNITS,LABEL,FORMAT," +define WCS_CRVAL 1 +define WCS_CRPIX 2 +define WCS_CD 3 +define WCS_LTV 4 +define WCS_LTM 5 +define WCS_WTYPE 6 +define WCS_AXTYPE 7 +define WCS_UNITS 8 +define WCS_LABEL 9 +define WCS_FORMAT 10 + +procedure t_wcsedit () + +bool interactive, verbose, update, install +int wcsdim, parno, naxes1, naxes2, ndim +pointer sp, imtemplate, image, parameter, ax1list, ax2list, axes1, axes2 +pointer value, wcs, system +pointer imlist, im, mwim, r, w, cd, ltm, ltv, iltm, nr, ncd +bool clgetb(), streq(), wcs_iedit() +int clgeti(), fstati(), wcs_decode_parno(), wcs_decode_axlist(), imtgetim() +int mw_stati() +pointer imtopen(), immap(), mw_openim(), mw_open() +errchk mw_newsystem() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (imtemplate, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (parameter, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (ax1list, SZ_FNAME, TY_CHAR) + call salloc (ax2list, SZ_FNAME, TY_CHAR) + call salloc (axes1, IM_MAXDIM, TY_INT) + call salloc (axes2, IM_MAXDIM, TY_INT) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (system, SZ_FNAME, TY_CHAR) + + # Get the list of images, parameter to be edited, axes lists, + # and new parameter value. + call clgstr ("image", Memc[imtemplate], SZ_FNAME) + interactive = clgetb ("interactive") + + if (! interactive) { + + # Get and check the wcs parameter to be edited. + call clgstr ("parameter", Memc[parameter], SZ_FNAME) + parno = wcs_decode_parno (Memc[parameter], SZ_FNAME) + if (parno <= 0) { + call printf ("%s is not a legal WCS parameter\n") + call pargstr (Memc[parameter]) + call sfree (sp) + return + } + + # Get the new parameter value. + call clgstr ("value", Memc[value], SZ_FNAME) + + # Get the axes for which the parameter is to be edited. + call clgstr ("axes1", Memc[ax1list], SZ_FNAME) + if (parno == WCS_CD || parno == WCS_LTM) + call clgstr ("axes2", Memc[ax2list], SZ_FNAME) + else + Memc[ax2list] = EOS + + # Print any axis decoding error messages. + if (wcs_decode_axlist (parno, Memc[ax1list], Memc[ax2list], + IM_MAXDIM, Memi[axes1], naxes1, Memi[axes2], naxes2) == ERR) { + if (naxes1 <= 0) { + call printf ("Error decoding axes1 list\n") + } else if ((Memi[axes1] < 1) || (Memi[axes1+naxes1-1] > + IM_MAXDIM)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (IM_MAXDIM) + } else if (naxes2 == 0) { + call printf ("Error decoding axes2 list\n") + } else if ((Memi[axes2] < 1) || (Memi[axes2+naxes2-1] > + IM_MAXDIM)) { + call printf ("The axes2 values must be >= 1 and <= %d\n") + call pargi (IM_MAXDIM) + } + call sfree (sp) + return + } + } + + # Get the remaining parameters. + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + wcsdim = clgeti ("wcsdim") + verbose = clgetb ("verbose") + update = clgetb ("update") + + # Loop over the list of images + imlist = imtopen (Memc[imtemplate]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Remove any image section. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + + # Open the image and the wcs. + iferr (im = immap (Memc[image], READ_WRITE, 0)) { + im = immap (Memc[image], NEW_IMAGE, 0) + IM_NDIM(im) = 0 + ndim = wcsdim + mwim = mw_open (NULL, ndim) + call mw_newsystem (mwim, Memc[wcs], ndim) + } else { + mwim = mw_openim (im) + iferr (call mw_ssystem (mwim, Memc[wcs])) { + call mw_close (mwim) + ndim = IM_NDIM(im) + mwim = mw_open (NULL, ndim) + call mw_newsystem (mwim, Memc[wcs], ndim) + } else + ndim = mw_stati (mwim, MW_NPHYSDIM) + } + call mw_gsystem (mwim, Memc[system], SZ_FNAME) + + # Allocate working memory. + call malloc (r, ndim * ndim, TY_DOUBLE) + call malloc (w, ndim * ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim * ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + # Compute the original world to logical transformation. + call mw_gwtermd (mwim, Memd[r], Memd[w], Memd[cd], ndim) + call mw_gltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + + # Edit the wcs. + if (interactive) { + + install = wcs_iedit (mwim, Memc[image], Memc[system], + Memd[ltv], Memd[ltm], Memd[w], Memd[nr], Memd[ncd], + ndim, verbose) + + } else if (streq (Memc[wcs], "physical") || streq (Memc[wcs], + "world") || streq (Memc[wcs], Memc[system])) { + + install = false + if (Memi[axes1+naxes1-1] > ndim) { + call printf ("For image %s axes1 values must be <= %d\n") + call pargstr (Memc[image]) + call pargi (ndim) + } else if (Memi[axes2+max(1,naxes2)-1] > ndim) { + call printf ( + "For image %s axes1,2 values must be <= %d\n") + call pargstr (Memc[image]) + call pargi (ndim) + } else { + + call wcs_edit (mwim, parno, Memi[axes1], naxes1, + Memi[axes2], naxes2, Memc[value], Memd[ltv], + Memd[ltm], Memd[w], Memd[nr], Memd[ncd], ndim) + + if (verbose) + call wcs_show (mwim, Memc[image], Memc[system], + Memd[ltv], Memd[ltm], Memd[w], Memd[nr], + Memd[ncd], ndim) + + if (update) + install = true + } + + } else { + call printf ("Cannot find wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + + + # Recompute and store the new wcs if update is enabled. + if (install) { + call mw_sltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) + call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) + call mw_swtermd (mwim, Memd[nr], Memd[w], Memd[cd], ndim) + call mw_saveim (mwim, im) + } + + # Free the memory. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + call mw_close (mwim) + call imunmap (im) + } + + call imtclose (imlist) + call sfree (sp) +end + + +# WCS_IEDIT -- Interactively edit the wcs. + +bool procedure wcs_iedit (mwim, image, system, ltv, ltm, w, r, cd, ndim, + verbose) + +pointer mwim # pointer to the current wcs +char image[ARB] # input image name +char system[ARB] # wcs system name +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs +bool verbose # verbose mode + +bool update +int cmd, parno, naxes1, naxes2 +pointer sp, parameter, value, ax1list, ax2list, axes1, axes2 +int clscan(), strdic(), nscan(), wcs_decode_parno(), wcs_decode_axlist() + +begin + # Allocate working memory. + call smark (sp) + call salloc (parameter, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (ax1list, SZ_FNAME, TY_CHAR) + call salloc (ax2list, SZ_FNAME, TY_CHAR) + call salloc (axes1, ndim, TY_INT) + call salloc (axes2, ndim, TY_INT) + + # Print the starting wcs. + if (verbose) + call wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + + # Loop over the command stream. + update = false + while (clscan ("commands") != EOF) { + + # Get the command/parameter. + call gargwrd (Memc[parameter], SZ_FNAME) + if (nscan() < 1) + next + cmd = strdic (Memc[parameter], Memc[parameter], SZ_FNAME, WCSCMDS) + + switch (cmd) { + case WCS_HELP: + call pagefile (HELPFILE, "") + case WCS_SHOW: + call wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + case WCS_UPDATE: + update = true + break + case WCS_QUIT: + update = false + break + default: + call gargwrd (Memc[value], SZ_FNAME) + call gargwrd (Memc[ax1list], SZ_FNAME) + call gargwrd (Memc[ax2list], SZ_FNAME) + parno = wcs_decode_parno (Memc[parameter], SZ_FNAME) + if (parno <= 0) { + call printf ("%s is not a legal WCS parameter\n") + call pargstr (Memc[parameter]) + } else if (nscan() < 2) { + call wcs_pshow (mwim, parno, image, system, ltv, ltm, w, + r, cd, ndim) + } else if (wcs_decode_axlist (parno, Memc[ax1list], + Memc[ax2list], IM_MAXDIM, Memi[axes1], naxes1, Memi[axes2], + naxes2) == OK) { + call wcs_edit (mwim, parno, Memi[axes1], naxes1, + Memi[axes2], naxes2, Memc[value], ltv, ltm, w, r, cd, + ndim) + if (verbose) + call wcs_pshow (mwim, parno, image, system, ltv, ltm, + w, r, cd, ndim) + } else if (naxes1 <= 0) { + call printf ("Error decoding axes1 list\n") + } else if ((Memi[axes1] < 1) || (Memi[axes1+naxes1-1] > ndim)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (ndim) + } else if (naxes2 <= 0) { + call printf ("Error decoding axes2 list\n") + } else if ((Memi[axes2] < 1) || (Memi[axes2+naxes2-1] > ndim)) { + call printf ("The axes1 values must be >= 1 and <= %d\n") + call pargi (ndim) + } + } + } + + call sfree (sp) + + return (update) +end + + +# WCS_EDIT -- Edit the wcs. + +procedure wcs_edit (mwim, parameter, axis1, naxis1, axis2, naxis2, value, ltv, + ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +int parameter # parameter to be changed +int axis1[ARB] # list of axes1 for which to change value +int naxis1 # number of axis for to change value +int axis2[ARB] # list of cross-term axes +int naxis2 # number of cross-term axes +char value[ARB] # new wcs parameter value +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +double dval +int i, j, ip +int ctod() + +begin + ip = 1 + switch (parameter) { + case WCS_CRVAL: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + w[axis1[i]] = dval + } + case WCS_CRPIX: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + r[axis1[i]] = dval + } + case WCS_CD: + if (ctod (value, ip, dval) > 0) { + if (naxis2 == 0) { + do i = 1, naxis1 + cd[axis1[i],axis1[i]] = dval + } else { + do i = 1, naxis1 + do j = 1, naxis2 + cd[axis2[j],axis1[i]] = dval + } + } + case WCS_LTV: + if (ctod (value, ip, dval) > 0) { + do i = 1, naxis1 + ltv[axis1[i]] = dval + } + case WCS_LTM: + if (ctod (value, ip, dval) > 0) { + if (naxis2 == 0) { + do i = 1, naxis1 + ltm[axis1[i],axis1[i]] = dval + } else { + do i = 1, naxis1 + do j = 1, naxis2 + ltm[axis1[i],axis2[j]] = dval + } + } + case WCS_WTYPE: + do i = 1, naxis1 { + call mw_swtype (mwim, axis1[i], 1, value, "") + call mw_swattrs (mwim, axis1[i], "wtype", value) + } + case WCS_AXTYPE: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "axtype", value) + case WCS_UNITS: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "units", value) + case WCS_LABEL: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "label", value) + case WCS_FORMAT: + do i = 1, naxis1 + call mw_swattrs (mwim, axis1[i], "format", value) + default: + ; + } +end + + +# WCS_SHOW -- Print a quick summary of the current wcs. + +procedure wcs_show (mwim, image, system, ltv, ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +char image[ARB] # name of the imput image +char system[ARB] # name of the input wcs +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("\nIMAGE: %s CURRENT WCS: %s\n") + call pargstr (image) + call pargstr (system) + + # Print the axis banner. + call printf (" AXIS ") + do i = 1, ndim { + call printf ("%8d ") + call pargi (i) + } + call printf ("\n") + + # Print the crval parameters. + call printf (" CRVAL ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + call printf (" CRPIX ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + do i = 1, ndim { + call printf (" CD %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print the ltv parameters. + call printf (" LTV ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (ltv[i]) + } + call printf ("\n") + + # Print the ltm matrix. + do i = 1, ndim { + call printf (" LTM %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (ltm[i,j]) + } + call printf ("\n") + } + + # Print the transformation type. + call printf (" WTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "wtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the axis type. + call printf (" AXTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "axtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the units. + call printf (" UNITS ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "units", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the label. + call printf (" LABEL ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "label", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the format. + call printf (" FORMAT ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "format", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + call printf ("\n") + + call sfree (sp) +end + + +# WCS_PSHOW -- Print the current values of a specific parameter. + +procedure wcs_pshow (mwim, parno, image, system, ltv, ltm, w, r, cd, ndim) + +pointer mwim # pointer to the current wcs +int parno # print the parameter number +char image[ARB] # name of the imput image +char system[ARB] # name of the input wcs +double ltv[ARB] # the lterm offsets +double ltm[ndim,ARB] # the lterm rotation matrix +double w[ARB] # the fits crval parameters +double r[ARB] # the fits crpix parameters +double cd[ndim,ARB] # the fits rotation matrix +int ndim # the dimension of the wcs + +int i,j +pointer sp, str +errchk mw_gwattrs() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the image name and current wcs. + call printf ("\nIMAGE: %s CURRENT WCS: %s\n") + call pargstr (image) + call pargstr (system) + + # Print the axis banner. + call printf (" AXIS ") + do i = 1, ndim { + call printf ("%8d ") + call pargi (i) + } + call printf ("\n") + + switch (parno) { + # Print the crval parameters. + case WCS_CRVAL: + call printf (" CRVAL ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (w[i]) + } + call printf ("\n") + + # Print the crpix parameters. + case WCS_CRPIX: + call printf (" CRPIX ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (r[i]) + } + call printf ("\n") + + # Print the cd matrix. + case WCS_CD: + do i = 1, ndim { + call printf (" CD %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (cd[j,i]) + } + call printf ("\n") + } + + # Print the ltv parameters. + case WCS_LTV: + call printf (" LTV ") + do i = 1, ndim { + call printf ("%8g ") + call pargd (ltv[i]) + } + call printf ("\n") + + # Print the ltm matrix. + case WCS_LTM: + do i = 1, ndim { + call printf (" LTM %d ") + call pargi (i) + do j = 1, ndim { + call printf ("%8g ") + call pargd (ltm[i,j]) + } + call printf ("\n") + } + + # Print the transformation type. + case WCS_WTYPE: + call printf (" WTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "wtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the axis type. + case WCS_AXTYPE: + call printf (" AXTYPE ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "axtype", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the units. + case WCS_UNITS: + call printf (" UNITS ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "units", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the label. + case WCS_LABEL: + call printf (" LABEL ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "label", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + + # Print the format. + case WCS_FORMAT: + call printf (" FORMAT ") + do i = 1, ndim { + iferr (call mw_gwattrs (mwim, i, "format", Memc[str], SZ_LINE)) + Memc[str] = EOS + call printf ("%8s ") + call pargstr (Memc[str]) + } + call printf ("\n") + default: + call printf ("Unknown WCS parameter\n") + } + call printf ("\n") + + call sfree (sp) +end + + +# WCS_DECODE_PARNO -- Decode the WCS parameter + +int procedure wcs_decode_parno (parameter, maxch) + +char parameter[ARB] # parameter name +int maxch # maximum length of parameter name + +int parno +int strdic() + +begin + # Get and check the wcs parameter to be edited. + call strupr (parameter) + parno = strdic (parameter, parameter, maxch, WCSPARS) + if (parno <= 0) + return (ERR) + else + return (parno) +end + + +# WCS_DECODE_AXES -- Decode the axes lists. + +int procedure wcs_decode_axlist (parno, ax1list, ax2list, max_naxes, axes1, + naxes1, axes2, naxes2) + +int parno # parameter to be edited +char ax1list[ARB] # principal axes list +char ax2list[ARB] # secondary axes list +int max_naxes # maximum number of axes to decode +int axes1[ARB] # list of principal axes to be edited +int naxes1 # number of principal axes to be edited +int axes2[ARB] # list of secondary axes to be edited +int naxes2 # number of secondary axes to be edited + +int wcs_getaxes() + +begin + naxes1 = wcs_getaxes (ax1list, axes1, max_naxes) + if (naxes1 <= 0 || naxes1 > max_naxes) + return (ERR) + else if ((axes1[1] < 1) || (axes1[naxes1] > max_naxes)) + return (ERR) + + # Get the second list of axes. + if ((parno == WCS_CD) || (parno == WCS_LTM)) { + naxes2 = wcs_getaxes (ax2list, axes2, max_naxes) + if (ax2list[1] == EOS) + return (OK) + else if (naxes2 == 0) + return (ERR) + else if ((axes2[1] < 0) || (axes2[naxes2] > max_naxes)) + return (ERR) + } else { + naxes2 = naxes1 + call amovi (axes1, axes2, naxes1) + } + + return (OK) +end + + +define MAX_NRANGES 10 + +# WCS_GETAXES -- Decode the input axis list. + +int procedure wcs_getaxes (axlist, axes, max_naxes) + +char axlist[ARB] # the axis list to be decoded +int axes[ARB] # the output decode axes +int max_naxes # the maximum number of output axes + +int naxes, axis, ranges[3,MAX_NRANGES+1] +int decode_ranges(), get_next_number() + +begin + # Clear the axes array. + call aclri (axes, max_naxes) + + # Check for a blank string. + if (axlist[1] == EOS) + return (0) + + # Check for an illegal axis list string. + if (decode_ranges (axlist, ranges, MAX_NRANGES, naxes) == ERR) + return (0) + + naxes = 0 + axis = 0 + while ((naxes < max_naxes) && (get_next_number (ranges, axis) != EOF)) { + naxes = naxes + 1 + axes[naxes] = axis + } + + return (naxes) +end diff --git a/pkg/images/imcoords/src/t_wcsreset.x b/pkg/images/imcoords/src/t_wcsreset.x new file mode 100644 index 00000000..d7c24f27 --- /dev/null +++ b/pkg/images/imcoords/src/t_wcsreset.x @@ -0,0 +1,142 @@ +include +include +include + +# T_WCSRESET -- Initialize the image wcs. The user can initialize the +# pre-defined "physical" or "world" coodinate systems, or a named +# user world coordinate system, for example the "multipsec" world +# coordinate system. If the image does not have a previously defined wcs +# then wcsreset will create the identify wcs. + +procedure t_wcsreset () + +bool verbose +int ndim +pointer sp, imnamelist, image, wcs, system +pointer r, w, cd, ncd, nr, ltv, iltm, ltm +pointer imlist, im, mwim, mw +bool clgetb(), streq() +int imtgetim(), mw_stati() +pointer imtopen(), immap(), mw_openim(), mw_open() +errchk mw_openim() + +begin + # Allocate working space. + call smark (sp) + call salloc (imnamelist, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (system, SZ_FNAME, TY_CHAR) + + # Get the parameters. + call clgstr ("image", Memc[imnamelist], SZ_FNAME) + call clgstr ("wcs", Memc[wcs], SZ_FNAME) + verbose = clgetb ("verbose") + + # Loop through the list of images. + imlist = imtopen (Memc[imnamelist]) + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Remove any image section. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + + # Open the image. + im = immap (Memc[image], READ_WRITE, 0) + iferr { + if (verbose) { + call printf ("Initializing wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + mwim = mw_openim (im) + } then { + mwim = NULL + } else { + call mw_gsystem (mwim, Memc[system], SZ_FNAME) + } + + # Reset the lterm only if the wcs is "physical". + if (streq (Memc[wcs], "physical") && mwim != NULL) { + + # Allocate space for the transforms. + ndim = mw_stati (mwim, MW_NPHYSDIM) + call malloc (r, ndim * ndim, TY_DOUBLE) + call malloc (w, ndim * ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (ltm, ndim * ndim, TY_DOUBLE) + call malloc (ltv, ndim, TY_DOUBLE) + call malloc (iltm, ndim * ndim, TY_DOUBLE) + call malloc (nr, ndim * ndim, TY_DOUBLE) + call malloc (ncd, ndim * ndim, TY_DOUBLE) + + call mw_gwtermd (mwim, Memd[r], Memd[w], Memd[cd], ndim) + call mw_gltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], ndim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[cd], Memd[iltm], Memd[ncd], ndim) + call mw_swtermd (mwim, Memd[nr], Memd[w], Memd[ncd], ndim) + call wcs_terminit (Memd[ltm], Memd[ltv], ndim) + call mw_sltermd (mwim, Memd[ltm], Memd[ltv], ndim) + call mw_saveim (mwim, im) + + # Free the space. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (ncd, TY_DOUBLE) + call mfree (nr, TY_DOUBLE) + call mfree (ltm, TY_DOUBLE) + call mfree (ltv, TY_DOUBLE) + call mfree (iltm, TY_DOUBLE) + + # Cannot replace physical system for unknown world system. + } else if (streq (Memc[wcs], "physical") && mwim == NULL) { + if (verbose) { + call printf ("\tCannot initialize wcs %s for image %s\n") + call pargstr (Memc[wcs]) + call pargstr (Memc[image]) + } + } else if (streq (Memc[wcs], "world") || streq (Memc[wcs], + Memc[system])) { + + ndim = IM_NDIM(im) + mw = mw_open (NULL, ndim) + call mw_saveim (mw, im) + call mw_close (mw) + + # The named wcs is not present. + } else { + call eprintf ("\tCannot find wcs %s\n") + call pargstr (Memc[wcs]) + } + + if (mwim != NULL) + call mw_close (mwim) + + call imunmap (im) + + } + + call imtclose (imlist) + + call sfree (sp) +end + + +# WCS_TERMINIT -- Initialize the shift term and rotation matrix. + +procedure wcs_terminit (ltm, ltv, ndim) + +double ltm[ndim,ndim] # the rotation matrix +double ltv[ndim] # the shift vector +int ndim # the number of dimensions + +int i + +begin + call aclrd (ltm, ndim * ndim) + do i = 1, ndim + ltm[i,i] = 1.0d0 + call aclrd (ltv, ndim) +end diff --git a/pkg/images/imcoords/src/ttycur.key b/pkg/images/imcoords/src/ttycur.key new file mode 100644 index 00000000..f91b2185 --- /dev/null +++ b/pkg/images/imcoords/src/ttycur.key @@ -0,0 +1,49 @@ + INTERACTIVE KEYSTROKE COMMANDS + +The following commands must be terminated by a carriage return. + +? Print help +: Execute colon command +data Measure object +q Exit task + + + VALID DATA STRING + +x/ra/long y/dec/lat [pmra pmdec [parallax radial velocity]] + +... x/ra/long y/dec/lat must be in pixels or the input units +... pmra and pmdec must be in " / year +... parallax must be in " +... radial velocity must be in km / sec + + COLON COMMANDS + +The following commands must be terminated by a carriage return. + +:show Show the input and output coordinate systems +:isystem [string] Show / set the input coordinate system +:osystem [string] Show / set the output coordinate system +:iunits [string string] Show / set the input coordinate units +:ounits [string string] Show / set the output coordinate units +:oformat [string string] Show / set the output coordinate format + + VALID INPUT AND OUTPUT COORDINATE SYSTEMS + +image [logical/tv/physical/world] +equinox [epoch] +noefk4 [equinox [epoch]] +fk4 [equinox [epoch]] +fk5 [equinox [epoch]] +icrs [equinox [epoch]] +apparent epoch +ecliptic epoch +galactic [epoch] +supergalactic [epoch] + + VALID INPUT AND OUTPUT CELESTIAL COORDINATE UNITS + AND THEIR DEFAULT FORMATS + +hours %12.3h +degrees %12.2h +radians %13.7g diff --git a/pkg/images/imcoords/src/wcsedit.key b/pkg/images/imcoords/src/wcsedit.key new file mode 100644 index 00000000..61d98ceb --- /dev/null +++ b/pkg/images/imcoords/src/wcsedit.key @@ -0,0 +1,24 @@ + WCSEDIT COMMANDS + + BASIC COMMANDS + + +? Print the WCSEDIT commands +show Print out the current WCS +update Quit WCSEDIT and update the image WCS +quit Quit WCSEDIT without updating the image wcs + + + PARAMETER DISPLAY AND EDITING COMMANDS + +crval [value axes1] Show/set the FITS crval parameter(s) +crpix [value axes1] Show/set the FITS crpix parameter(s) +cd [value axes1 [axes2]] Show/set the FITS cd parameter(s) +ltv [value axes1] Show/set the IRAF ltv parameter(s) +ltm [value axes1 [axes2]] Show/set the IRAF ltm parameter(s) +wtype [value axes1] Show/set the FITS/IRAF axes transform(s) +axtype [value axes1] Show/set the FITS/IRAF axis type(s) +units [value axes1] Show/set the IRAF axes units(s) +label [value axes1] Show/set the IRAF axes label(s) +format [value axes1] Show/set the IRAF axes coordinate format(s) + diff --git a/pkg/images/imcoords/src/x_starfind.x b/pkg/images/imcoords/src/x_starfind.x new file mode 100644 index 00000000..865a795d --- /dev/null +++ b/pkg/images/imcoords/src/x_starfind.x @@ -0,0 +1 @@ +task starfind = t_starfind diff --git a/pkg/images/imcoords/starfind.par b/pkg/images/imcoords/starfind.par new file mode 100644 index 00000000..73d80255 --- /dev/null +++ b/pkg/images/imcoords/starfind.par @@ -0,0 +1,25 @@ +# STARFIND + +image,f,a,,,,Input image +output,f,a,default,,,Output star list +hwhmpsf,r,a,1.0,,,HWHM of the PSF in pixels +threshold,r,a,100.0,0.0,,Detection threshold in ADU +datamin,r,h,INDEF,,,Minimum good data value in ADU +datamax,r,h,INDEF,,,Maximum good data value in ADU +fradius,r,h,2.5,1.0,,Fitting radius in HWHM +sepmin,r,h,5.0,1.0,,Minimum separation in HWHM +npixmin,i,h,5,5,,Minimum number of good pixels above background +maglo,r,h,INDEF,,,Lower magnitude limit +maghi,r,h,INDEF,,,Upper magnitude limit +roundlo,r,h,0.0,0.0,,Lower ellipticity limit +roundhi,r,h,0.2,0.0,1.0,Upper ellipticity limit +sharplo,r,h,0.5,,,Lower sharpness limit +sharphi,r,h,2.0,,,Upper sharpness limit +wcs,s,h,"",,,"World coordinate system (logical,physical,world)" +wxformat,s,h,"",,,The x axis world coordinate format +wyformat,s,h,"",,,The y axis world coordinate format +boundary,s,h,nearest,"|nearest|constant|reflect|wrap",,"Boundary extension (nearest,constant,reflect,wrap)" +constant,r,h,0.0,,,Constant for constant boundary extension +nxblock,i,h,INDEF,,,X dimension of working block size in pixels +nyblock,i,h,256,,,Y dimension of working block size in pixels +verbose,b,h,no,,,Print messages about the progress of the task diff --git a/pkg/images/imcoords/wcsctran.par b/pkg/images/imcoords/wcsctran.par new file mode 100644 index 00000000..ec8ad4ad --- /dev/null +++ b/pkg/images/imcoords/wcsctran.par @@ -0,0 +1,12 @@ +# Parameter file for the WCSTRAN task. + +input,s,a,"",,,The input coordinate files +output,s,a,"",,,The output coordinate files +image,f,a,"",,,The input images +inwcs,s,a,"logical","|logical|tv|physical|world|",,The input coordinate system +outwcs,s,a,"world","|logical|tv|physical|world|",,The output coordinate system +columns,s,h,"1 2 3 4 5 6 7",,,List of input file columns +units,s,h,"",,,List of input coordinate units +formats,s,h,"",,,List of output coordinate formats +min_sigdigits,i,h,7,,,Minimum precision of output coordinates +verbose,b,h,yes,,,Write comments to the output file ? diff --git a/pkg/images/imcoords/wcsedit.par b/pkg/images/imcoords/wcsedit.par new file mode 100644 index 00000000..3b40ef98 --- /dev/null +++ b/pkg/images/imcoords/wcsedit.par @@ -0,0 +1,13 @@ +# Parameter file for WCSEDIT + +image,f,a,,,,"List of input images" +parameter,s,a,,,,"The wcs parameter to be edited" +value,s,a,,,,"The new parameter value" +axes1,s,a,"",,,"Independent axes for which parameter is to be edited" +axes2,s,a,"",,,"Dependent axes for which parameter is to be edited" +wcs,s,h,"world",,,"Default world coordinate system to be edited" +wcsdim,i,h,2,1,,"WCS dimensionality for new images" +interactive,b,h,no,,,"Interactive mode ?" +commands,*s,h,,,,"wcsedit" +verbose,b,h,yes,,,"Print messages about actions taken ?" +update,b,h,yes,,,"Update the image header ?" diff --git a/pkg/images/imcoords/wcsreset.par b/pkg/images/imcoords/wcsreset.par new file mode 100644 index 00000000..6a12652a --- /dev/null +++ b/pkg/images/imcoords/wcsreset.par @@ -0,0 +1,5 @@ +# Parameter file for WCSRESET + +image,f,a,,,,"List of input images" +wcs,s,a,physical,,,"Name of wcs to be initialized" +verbose,b,h,yes,,,"Print messages about actions taken ?" diff --git a/pkg/images/imfilter/Revisions b/pkg/images/imfilter/Revisions new file mode 100644 index 00000000..0e209772 --- /dev/null +++ b/pkg/images/imfilter/Revisions @@ -0,0 +1,2025 @@ +.help revisions Jan97 images.imfilter +.nf +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/imfilter/boxcar.par b/pkg/images/imfilter/boxcar.par new file mode 100644 index 00000000..883f402a --- /dev/null +++ b/pkg/images/imfilter/boxcar.par @@ -0,0 +1,9 @@ +# BOXCAR FILTER + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +xwindow,i,a,,,,X dimension of box +ywindow,i,a,,,,Y dimension of box +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +mode,s,h,'ql' diff --git a/pkg/images/imfilter/convolve.par b/pkg/images/imfilter/convolve.par new file mode 100644 index 00000000..2a03e819 --- /dev/null +++ b/pkg/images/imfilter/convolve.par @@ -0,0 +1,13 @@ +# CONVOLUTION FILTER + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +kernel,s,a,,,,Kernel file +xkernel,s,a,,,,X dimension kernel file for bilinear kernels +ykernel,s,a,,,,Y dimension kernel file for bilinear kernels +bilinear,b,h,no,,,Is the kernel bilinear? +radsym,b,h,no,,,Is the kernel radially symmetric? +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +row_delimiter,s,h,";",,,Kernel row delimiter +mode,s,h,'ql' diff --git a/pkg/images/imfilter/doc/boxcar.hlp b/pkg/images/imfilter/doc/boxcar.hlp new file mode 100644 index 00000000..f0381128 --- /dev/null +++ b/pkg/images/imfilter/doc/boxcar.hlp @@ -0,0 +1,70 @@ +.help boxcar Nov85 images.imfilter +.ih +NAME +boxcar -- boxcar smooth a list of images +.ih +USAGE +boxcar input output xwindow ywindow +.ih +PARAMETERS +.ls input +List of images to be smoothed. +.le +.ls output +List of output images. The number of output images must equal the number of +input images. If the input images name equals the output image name the +smoothed image will replace the input image. +.le +.ls xwindow, ywindow +The size of the smoothing window. +.le +.ls boundary = "nearest" +The boundary extension options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The constant for constant-valued boundary extension. +.le + +.ih +DESCRIPTION + +BOXCAR smooths the list of images specified by \fIinput\fR with a +flat-topped rectangular kernel of dimensions \fIxwindow\fR by \fIywindow\fR +and places the smoothed images in \fIoutput\fR. The type of boundary +extension is optional and set by the \fIboundary\fR parameter. + +.ih +EXAMPLES + +1. Smooth an image using a 3 by 3 smoothing box and nearest neighbor boundary + extension. + +.nf + cl> boxcar m82 m82.box 3 3 +.fi + +.ih +TIME REQUIREMENTS + +BOXCAR requires approximately 30 cpu seconds to smooth a +512 square real image with a 5 by 5 kernel (VAX 11/750 with fpa). + +.ih +BUGS + +.ih +SEE ALSO +convolve, gauss, laplace, gradient +.endhelp diff --git a/pkg/images/imfilter/doc/convolve.hlp b/pkg/images/imfilter/doc/convolve.hlp new file mode 100644 index 00000000..2df14ca8 --- /dev/null +++ b/pkg/images/imfilter/doc/convolve.hlp @@ -0,0 +1,167 @@ +.help convolve Jan91 images.imfilter +.ih +NAME +convolve -- convolve an image with an arbitrary rectangular kernel +.ih +USAGE +convolve input output kernel +.ih +PARAMETERS +.ls input +List of images to be convolved with the rectangular kernel. +.le +.ls output +List of output images. The number of output images must equal the number of +input images. If the input image name equals the output image name the +convolved image will replace the input image. +.le +.ls kernel +A text file name or a string listing the 2D kernel elements. +The kernel elements are separated by whitespace or commas and the kernel rows +are delimited by \fIrow_delimiter\fR. +In string entry mode the elements are assumed to be in row order. +In text file entry mode the \fIlast\fR row of the +kernel is the \fIfirst\fR row of the text file. +\fIKernel\fR is requested if \fIbilinear\fR is "no". +.le +.ls xkernel +A text file or string containing the 1D x dimension component of the bilinear +convolution kernel. The kernel elements are separated by whitespace +or commas. \fIXkernel\fR is requested if \fIbilinear\fR is "yes". +.le +.ls ykernel +A text file or string containing the 1D y dimension component of the bilinear +convolution kernel. The kernel elements are separated by whitespace +or commas. \fIYkernel\fR is requested if \fIbilinear\fR is "yes". +.le +.ls bilinear +Is the convolution kernel bilinear? If \fIbilinear\fR is yes, then the full 2D +convolution kernel \fIkernel\fR can be expressed as two independent 1D +convolutions \fIxkernel\fR and \fIykernel\fR, +and a more efficient convolution algorithm is used. +.le +.ls radsym = no +Is the convolution kernel radially symmetric? If radsym "yes", a more efficient +convolution algorithm is used. +.le +.ls boundary = "nearest" +The algorithm used to compute the values of the out of bounds pixels. The +options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The constant for constant-valued boundary extension. +.le +.ls row_delimiter = ";" +The row delimiter character for multi-row kernels. +.le + +.ih +DESCRIPTION + +CONVOLVE convolves the list of images specified by \fIinput\fR with an +arbitrary user supplied rectangular kernel \fIkernel\fR (if \fIbilinear\fR +is "no") or two equivalent 1D kernels \fIxkernel\fR and \fIykernel\fR +(if \fIbilinear\fR is "yes") and places the convolved images in \fIoutput\fR. +Out of bounds pixels are computed using the algorithm specified +by \fIboundary\fR. + +\fIKernel\fR or alternatively \fIxkernel\fR and \fIykernel\fR is either a +text file name or a short string listing the kernel elements. +The kernel elements are separated by whitespace or commas and the kernel rows +are delimited by the character \fIrow_delimiter\fR. +In string entry mode the elements are assumed to be in row order. +In text file entry mode the \fIlast\fR row of the +kernel is the \fIfirst\fR row of the text file. + +The parameters \fIbilinear\fR and \fIradsym\fR can be used to greatly +speed up the convolution task for convolution kernels which have +the appropriate mathematical form. Bilinear convolution kernels +are those which define a function which is mathematically separable in +the x and y dimension. In this case convolving each line of the input +image with \fIxkernel\fR and then convolving each column of this intermediate +image with \fIykernel\fR, is operationally equivalent to convolving +each point in the entire image with the full 2D kernel \fIkernel\fR. +Radially symmetric kernels are those which are symmetric about some +central point. + +.ih +EXAMPLES +Examples 1 and 2 use the following kernel where -1 is element 1 of row 1. + +.nf + 1. 1. 1. + kernel = 0. 0. 0. + -1. -1. -1. +.fi + +1. Convolve an image with the above kernel using string entry mode and wrap +around boundary extension. + +.nf + cl> convolve m82 m82.cnv "-1. -1. -1.; 0. 0. 0.; 1. 1. 1." bound=wrap +.fi + +2. Type the contents of the kernel file fdy on the terminal. Convolve an image +with the kernel in fdy using nearest neighbor boundary extension. + +.nf + cl> type fdy + + 1. 1. 1.; + 0. 0. 0.; + -1. -1. -1.; + + cl> convolve m74 m74.cnv fdy +.fi + +Example 3 uses the following bilinear kernel, where x# and y# are elements +of xkernel and ykernel respectively. + +.nf + xkernel = .2500 .5000 .2500 + + ykernel = .2500 .5000 .2500 + + .0625 .1250 .0625 y1*x1 y1*x2 y1*x3 + kernel = .1250 .2500 .1250 = y2*x1 y2*x2 y2*x3 + .0625 .1250 .0625 y3*x1 y3*x2 y3*x3 + +.fi + +3. Convolve an image with the full 2D kernel and with the the equivalent +1D kernels xkernel and ykernel and compare the results. + +.nf + cl> convolve m92 m92.1 kernel + + cl> convolve m92 m92.2 xkernel ykernel bilinear+ + + cl> imarith m92.1 - m92.2 diff +.fi + +.ih +TIME REQUIREMENTS +CONVOLVE requires approximately 30 and 8 cpu seconds to convolve a +512 square real image with 17 by 17 radially symmetric convolution kernel +using the full 2D and bilinear kernels (if appropriate) respectively +on a Sparc Station 1. + +.ih +BUGS + +.ih +SEE ALSO +gauss, laplace, gradient, boxcar +.endhelp diff --git a/pkg/images/imfilter/doc/fmedian.hlp b/pkg/images/imfilter/doc/fmedian.hlp new file mode 100644 index 00000000..17e85788 --- /dev/null +++ b/pkg/images/imfilter/doc/fmedian.hlp @@ -0,0 +1,165 @@ +.help fmedian May95 images.imfilter +.ih +NAME +fmedian -- quantize and box median filter a list of images +.ih +USAGE +fmedian input output xwindow ywindow +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of output filtered images. The number of input images must be the +same as the number of output images. If the input image name equals the output +image name the filtered image replaces the original image. +.le +.ls xwindow, ywindow +The size of the box median filter. Xwindow and ywindow must be odd. +Even values for xwindow or ywindow will be rounded up to the +nearest odd integer. +.le +.ls hmin = -32768, hmax = 32767 +The histogram quantization parameters. Hmin and hmax define the minimum +and maximum permitted values for the integer representation of the input image. +The default values are appropriate for the 16 bit twos complement data values +produced by current CCDs. Hmin and hmax should be chosen so as to +minimize the space required to store the image histogram. +.le +.ls zmin = INDEF, zmax = INDEF +The data quantization parameters. Zmin and zmax default to the minimum and +maximum pixel values in the input image. Pixel values from zmin to zmax are +linearly mapped to integer values from hmin to hmax. If zmin = hmin and +zmax = hmax, the image pixels are converted directly to integers. +Image values less than or greater than +zmin or zmax will default to hmin and hmax respectively. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to zmin and zmax in the input data or equivalently to hmin and hmax in the +integer representation of the input image. +.le +.ls unmap = yes +Fmedian rescales the integer values to numbers between zmin and zmax +by default. If the user wishes to preserve the median of the quantized +images the unmap parameter should be set to no. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le +.ih +DESCRIPTION + +FMEDIAN takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The filter consists of a sliding rectangular +\fIxwindow\fR by \fIywindow\fR window whose function is to replace the +center pixel in the window with the median of the pixels in the +window. The median of a sequence of numbers is defined to be +the value of the (n + 1) / 2 pixel in the ordered sequence. +Out-of-bounds pixel references are handled by setting the parameter +\fIboundary\fR. + +If \fIzmin\fR = \fIhmin\fR and \fIzmax\fR = \fIhmax\fR, +FMEDIAN converts the image pixels directly to +integers. This operation may result in truncation of the pixel values +if the input image is not an integer image. Otherwise the +input pixel values from zmin to zmax are linearly mapped to integer +values from hmin to hmax. The histogram, median, and number of pixels less +than the median, are computed for the first window position. These +quantities are updated as the median filter moves one position. +The \fIunmap\fR parameter is normally set so as to restore the output +pixel values to the range defined by zmin and zmax, but may be turned off +if the user wishes to examine the quantized pixels. The precision of the +median in integer space and pixel space is 1.0 and +(zmax - zmin) / (hmax - hmin) respectively. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to +reject bad data from the median filtering box. If no good +data is left in a give filtering box, then the median is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +A description of the fast median algorithm used here can be found in +"Topics in Applied Physics: Two-Dimensional Digital Signal Processing II: +Transforms and Median Filters", Volume 43, 1981, Springer-Verlag, +edited by T.S. Huang, p 209. + +.ih +EXAMPLES + +1. Median filter a 16 bit CCD image using a 5 by 5 window. + +.nf + im> fmedian input output 5 5 hmin=-32768 hmax=32767 \ + >>> zmin=-32768. zmax=32767. +.fi + +2. Median filter a KPNO PDS image using a 3 by 3 window. + +.nf + im> fmedian input output 3 3 hmin=0 hmax=4095 zmin=0. zmax=4095. +.fi + +3. Median filter an 8 bit image using a 3 by 3 window. + +.nf + im> fmedian input output 3 3 hmin=0 hmax=255 zmin=0. zmax=255. +.fi + +4. Median filter an image with real values from 0.0 to 1.0 with a precision +of .003 and leave the output pixels in integer format. + +.nf + im> fmedian input output 5 5 unmap- hmin=0 hmax=1000 zmin=0. \ + >>> zmax=1. +.fi + +5. Median filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the medianing process. + +.nf + im> fmedian dev$pix output 5 5 hmin=-1 hmax=20000 zmin=-1.0 \ + >>> zmax=20000 zloreject=5 zhireject=20000 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 4.5 and 5.8 CPU seconds to median filter an +512 by 512 square integer image with a 5 by 5 and 7 by 7 window respectively. +(SPARCStation2). + +.ih +BUGS +This technique is most suitable for integer data or data which has not +been calibrated. For non-integer data the calculated median may be an +approximation, not an exact pixel value. + +If the dynamic range of the data defined by hmin and hmax is large the +memory requirements can become very large. + +.ih +SEE ALSO +median, frmedian +.endhelp diff --git a/pkg/images/imfilter/doc/fmode.hlp b/pkg/images/imfilter/doc/fmode.hlp new file mode 100644 index 00000000..d223d2a6 --- /dev/null +++ b/pkg/images/imfilter/doc/fmode.hlp @@ -0,0 +1,176 @@ +.help fmode May95 images.imfilter +.ih +NAME +fmode -- quantize and box modal filter a list of images +.ih +USAGE +fmode input output xwindow ywindow +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as the +number of output images. If the input image name equals the output image name +the filtered image replaces the original image. +.le +.ls xwindow, ywindow +The size of the modal filter. Xwindow and ywindow must be odd. +Even values for xwindow or ywindow will be rounded up to the +nearest odd integer. +.le +.ls hmin = -32768, hmax = 32767 +The histogram quantization parameters. Hmin and hmax define the minimum +and maximum permitted values for the integer representation of the +input image. The default values are those suitable for the 16 bit twos +complement data produced by current CCDs. Hmin and hmax should be chosen +so as to minimize the space required to store the image histogram. +.le +.ls zmin = INDEF, zmax = INDEF +The quantization parameters. Zmin and zmax default to the minimum and +maximum pixel values in the input image. Pixel values from zmin to zmax +are linearly mapped to integer values from hmin to hmax. +If zmin = hmin and zmax = hmax, the image pixels are converted directly +to integers. Image values less than or greater than +zmin or zmax will default to hmin and hmax respectively. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to zmin and zmax in the input data or equivalently to hmin and hmax in the +integer representation of the input image. +.le +.ls unmap = yes +Fmode rescales the integer values to numbers between zmin and zmax +by default. If the user wishes to preserve the mode of the quantized images, +the \fIunmap\fR parameter should be set to no. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le + +.ih +DESCRIPTION + +FMODE takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The filter consists of a sliding rectangular +\fIxwindow\fR by \fIywindow\fR window whose function is to replace the +center pixel in the window with the mode of the pixels in the +window. The mode is defined in the expression below. + +.nf + mode = 3. * median - 2. * mean +.fi + +The median of a sequence of numbers is defined to be the value of the +(n + 1) / 2 pixel in the ordered sequence. Out-of-bounds pixel references are +handled by setting the parameter \fIboundary\fR. + +If \fIzmin\fR = \fIhmin\fR and \fIzmax\fR = \fIhmax\fR, FMODE converts +the image pixels directly +to integers. This operation may result in truncation of the pixel +values if the input image is not an integer image. +Otherwise the input pixel values from zmin to zmax are linearly mapped +to integer values from hmin to hmax. +The histogram, median, and number of pixels less +than the median, are computed for the first window position. These +quantities are then updated as the median filter moves one position and +the mode is recomputed. The \fIunmap\fR parameter is normally set so as to +restore the output pixel values to the range defined by zmin and zmax, +but may be turned off if the user wishes to examine the quantized pixels. +The precision of the mode in integer space and pixel space is 1.0 +and (zmax - zmin) / (hmax - hmin) respectively. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to +reject bad data from the modal filtering box. If no good +data is left in a given filtering box, then the mode is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +A description of the fast median algorithm used here can be found in +"Topics in Applied Physics: Two-Dimensional Digital Signal Processing II: +Transforms and Median Filters", Volume 43, 1981, Springer-Verlag, edited by +T.S. Huang, page 209. + +A derivation of the expression for the mode used here can be found in +"Statistics in Theory and Practice", Robert Lupton, 1993, Princeton +University Press, problem 2. + +.ih +EXAMPLES + +1. Modal filter a 16 bit CCD image using a 5 by 5 window. + +.nf + im> fmode input output 5 5 hmin=-32768 hmax=32767 zmin=-32768. \ + >>> zmax=32767. +.fi + +2. Modal filter a KPNO PDS image using a 3 by 3 window. + +.nf + im> fmode input output 3 3 hmin=0 hmax=4095 zmin=0. zmax=4095. +.fi + +3. Modal filter an 8 bit image using a 3 by 3 image. + +.nf + im> fmode input output 3 3 hmin=0 hmax=255 zmin=0. zmax=255. +.fi + +4. Modal filter an image with real values from 0.0 to 1.0 with a precision +of .003. + +.nf + im> fmode input output 5 5 hmin=0 hmax=1000 zmin=0. \ + >>> zmax=1. +.fi + +5. Modal filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the mode computing process. + +.nf + im> fmode dev$pix output 5 5 hmin=-1 hmax=20000 zmin=-1.0 \ + >>> zmax=20000 zloreject=5 zhireject=20000 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 6.1 and 7.6 CPU seconds to modal filter a +512 by 512 square integer image with a 5 by 5 and 7 by 7 window respectively +(SPARCStation2). + +.ih +BUGS +This technique is most suitable for integer data and data which has not +been calibrated. For non-integer data the calculated median is an +approximation only. + +If the dynamic range of the data defined by hmin and hmax is large the +memory requirements can become very large. + +.ih +SEE ALSO +mode, rmode, frmode +.endhelp diff --git a/pkg/images/imfilter/doc/frmedian.hlp b/pkg/images/imfilter/doc/frmedian.hlp new file mode 100644 index 00000000..8383b22a --- /dev/null +++ b/pkg/images/imfilter/doc/frmedian.hlp @@ -0,0 +1,191 @@ +.help frmedian May95 images.imfilter +.ih +NAME +frmedian -- quantize and ring median filter a list of input images +.ih +USAGE +frmedian input output rinner router +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as the +number of output images. If the input image name equals the output image name +the filtered images replaces the original image. +.le +.ls rinner, router +The inner and outer semi-major axes of the ring filter in pixels. If rinner +is set to 0.0 then the ring filter becomes a circular filter. +.le +.ls ratio = 1.0 +The ratio of the semi-minor axis to the semi-major axes of the ring filter. +If ratio is 1.0 the ring filter is circularly symmetric. +.le +.ls theta = 0.0 +The position angle of the major axis of the ring filter. Theta is measured +counter-clockwise in degrees from the x axis and must be between 0 and +180 degrees. +.le +.ls hmin = -32768, hmax = 32767 +The histogram quantization parameters. Hmin and hmax define the minimum and +maximum +permitted values for the integer representation of the input image. The +default values are those suitable for the 16 bit twos complement data +produced by current CCDs. Hmin and hmax should be chosen so as to +minimize the space required to store the image histogram. +.le +.ls zmin = INDEF, zmax = INDEF +The data quantization parameters. Zmin and zmax default to the minimum and +maximum pixel values in the input image. Pixel values from zmin to zmax +are linearly mapped to integer values from hmin to hmax. If zmin = hmin and +zmax = hmax, the image pixels are converted directly to integers. +Image values less than or greater than +zmin or zmax will default to hmin and hmax respectively. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to zmin and zmax in the input data or hmin and hmax in the integer +representation of the input image. +.le +.ls unmap = yes +Frmedian rescale the integer values to numbers between zmin and zmax +by default. If the user wishes to preserve the mode of the quantized +images, the unmap parameter should be set to no. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le + +.ih +DESCRIPTION + +FRMEDIAN takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The filter consists of a sliding +circular / elliptical or annular circular / elliptical window whose size +and orientation is determined +by the \fIrinner\fR, \fIrouter\fR, \fIratio\fR, and \fItheta\fR parameters. +The center pixel in the window is replaced by the median of the pixels in the +window, where the median of a sequence of numbers is defined to be +the value of the (n + 1) / 2 number in the ordered sequence. +Out of bounds pixel references are handled by setting the parameter +\fIboundary\fR. The principal function of the circular / elliptical filters +is to smooth an image using a circularly / elliptically symmetric filter. +The principal function of the circular / elliptical ring filter is to +remove objects from the image which have a scale length of rinner and +replace them with an estimate of the local background value. + +If \fIzmin\fR = \fIhmin\fR and \fIzmax\fR = \fIhmax\fR, FRMEDIAN converts +the image pixels directly to +integers. This operation may result in truncation of the pixel values +if the input image is not an integer image. Otherwise the +input pixel values from zmin to zmax are linearly mapped to integer +values from hmin to hmax. The histogram, median, and number of pixels less +than the median, are computed for the first window position. These +quantities are updated as the median filter moves one position. +The \fIunmap\fR parameter is normally set so as to restore the output +pixel values to the range defined by zmin to zmax, but may be turned off +if the user wishes to examine the quantized pixels. The precision of the +median in integer space and pixel space is 1.0 and +(zmax - zmin) / (hmax - hmin) respectively. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to reject +bad data from the median filtering box. If no good +data is left in a give filtering box, then the median is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +A description of the fast median algorithm used here can be found in +"Topics in Applied Physics: Two-Dimensional Digital Signal Processing II: +Transforms and Median Filters", Volume 43, 1981, Springer-Verlag, edited +by T.S. Huang, page 209. + +The properties of the ring median filter and its application to +astronomical data analysis problems is summarized in the +article "A Ring Median Filter for Digital Images" (Secker, J., 1995, +PASP, 107, 496-501) and reference therein. + +.ih +EXAMPLES + +1. Median filter a 16 bit CCD image using a circular ring filter with an inner +radius of 4 pixels and a width of 1 pixel. + +.nf + im> frmedian input output 4.0 5.0 hmin=-32768 hmax=32767 \ + >>> zmin=-32768. zmax=32767. +.fi + +2. Median filter a KPNO PDS image using a circular ring filter of outer +radius 3. + +.nf + im> frmedian input output 0.0 3.0 hmin=0 hmax=4095 zmin=0. zmax=4095. +.fi + +3. Median filter an 8 bit image using the same filter used in example 2. + +.nf + im> frmedian input output 0.0 3.0 hmin=0 hmax=255 zmin=0. zmax=255. +.fi + +4. Median filter an image with real values from 0.0 to 1.0 with a precision +of .003 and leave the output pixels in integer format. Use a ring filter of +inner radius 5.0 and width 0.5 pixels. + +.nf + im> frmedian input output 5.0 5.5 unmap- hmin=0 hmax=1000 zmin=0. \ + >>> zmax=1. +.fi + +5. Median filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the medianing process using a circular filter +of outer radius 5.0. + +.nf + im> frmedian dev$pix output 0.0 5.0 hmin=-1 hmax=20000 zmin=-1.0 \ + >>> zmax=20000 zloreject=5 zhireject=20000 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 30 and 22 cpu seconds to median filter a +512 by 512 square integer image with a circular filter of radius 5 pixels +and a ring filter of inner and outer radii of 4.0 and 5.0 pixels respectively. +(SPARCStation2). + +.ih +BUGS +This technique is most suitable for integer data and data which has not +been calibrated. For non-integer data the calculated median is an +approximation only. + +If the dynamic range of the data defined by hmin and hmax is large the +memory requirements can become very large. + +.ih +SEE ALSO +median, rmedian, fmedian +.endhelp diff --git a/pkg/images/imfilter/doc/frmode.hlp b/pkg/images/imfilter/doc/frmode.hlp new file mode 100644 index 00000000..a5f23448 --- /dev/null +++ b/pkg/images/imfilter/doc/frmode.hlp @@ -0,0 +1,197 @@ +.help frmode May95 images.imfilter +.ih +NAME +frmode -- quantize and ring modal filter a list of images +.ih +USAGE +frmode input output rinner router +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as the +number of output images. If the input image name equals the output image name +the filtered image replaces the original image. +.le +.ls rinner, router +The inner and outer semi-major axes of the ring filter in pixels. If rinner +is set to 0.0 then the ring filter becomes a circular filter. +.le +.ls ratio = 1.0 +The ratio of the semi-minor axis to the semi-major axis of the ring filter. +If ratio is 1.0 the ring filter is circularly symmetric. +.le +.ls theta = 0.0 +The position angle of the major axis of the ring filter. Theta is measured +in degrees counter-clockwise from the x axis and must be between 0 and 180 +degrees. +.le +.ls hmin = -32768, hmax = 32767 +The histogram quantization parameters. Hmin and hmax define the minimum +and maximum permitted values for the integer representation of the input image. +The default values are those suitable for the 16 bit twos complement data +produced by current CCDs. Hmin and hmax should be chosen so as to +minimize the space required to store the image histogram. +.le +.ls zmin = INDEF, zmax = INDEF +The data quantization parameters. Zmin and zmax default to the minimum and +maximum pixel values in the input image. Pixel values from zmin to zmax +are linearly mapped to integers from hmin to hmax. +If zmin = hmin and zmax = hmax, the image pixels are converted directly to +integers. Image values less than or greater than +zmin or zmax will default to hmin and hmax respectively. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to zmin and zmax in the input data or hmin and hmax in the integer +representation of the input image. +.le +.ls unmap = yes +Frmode rescales the integer values to numbers between zmin and zmax +by default. If the user wishes to preserve the mode of the quantized images, +the \fIunmap\fR parameter should be set to no. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le + +.ih +DESCRIPTION + +FRMODE takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The filter consists of a sliding +circular / elliptical or annular circular / elliptical window whose size +and orientation is determined by the \fIrinner\fR, \fIrouter\fR, \fIratio\fR, +and \fItheta\fR parameters. The center pixel of the window is replaced by +the mode of the pixels in the window, where the mode is defined as follows. + +.nf + mode = 3. * median - 2. * mean +.fi + +The median of a sequence of numbers is defined to be the value of the +(n + 1) / 2 number in the ordered sequence. Out of bounds pixel references +are handled by setting the parameter boundary. The principal function of +the circular / elliptical filters is to smooth an image using a +circularly / elliptically symmetric filter. The principal function of the +circular / elliptical ring filter is to remove objects from the image +which have a scale length or rinner and replace them with an estimate of +the local background value. + +If \fIzmin\fR = \fIhmin\fR and \fIzmax\fR = \fIhmax\fR, +FRMODE converts the image pixels directly to integers. +This operation may result in truncation of the pixel values of the +input image is not an integer image. +Otherwise the input image values from zmin to zmax are linearly mapped to +integer values from hmin to hmax. +The histogram, median, and number of pixels less +than the median are computed for the first window position. These +quantities are updated as the median filter moves one position and +the mode is computed. The \fIunmap\fR parameter is normally set +so as to restore the output pixel values to the range defined by +zmin and zmax, but may be turned off if the user wishes to +examine the quantized pixels. +The precision of the mode in integer space and pixel space +is 1.0 and (zmax - zmin) / (hmax - hmin) respectively. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to reject +bad data from the modal filtering box. If no good +data is left in the filtering box, then the mode is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +A description of the fast median algorithm used here can be found in +"Topics in Applied Physics: Two-Dimensional Digital Signal Processing II: +Transforms and Median Filters", Volume 43, 1981, Springer-Verlag, +edited by T.S. Huang, page 209. + +The properties of the ring median filter and its application to +astronomical data analysis problems is summarized in the +article "A Ring Median Filter for Digital Images" (Secker, J., 1995, +PASP, 107, 496-501) and references therein. + +.ih +EXAMPLES + +1. Modal filter a 16 bit CCD image using a circular ring filter with an +inner radius of 4 pixels and a width of 1 pixel. + +.nf + im> frmode input output 4.0 5.0 hmin=-32768 hmax=32767 zmin=-32768. \ + >>> zmax=32767. +.fi + +2. Modal filter a KPNO PDS image using a circular filter of outer radius +3.0. + +.nf + im> frmode input output 0.0 3.0 hmin=0 hmax=4095 zmin=0. zmax=4095. +.fi + +3. Modal filter an 8 bit image using the same filter as example 2. + +.nf + im> frmode input output 0.0 3.0 hmin=0 hmax=255 zmin=0. zmax=255. +.fi + +4. Modal filter an image with real values from 0.0 to 1.0 with a precision +of .003 and leave the output pixels in integer format. Use a ring filter +of inner radius 5.0 and width 0.5 pixels. + +.nf + im> frmode input output 5.0 0.5 unmap- hmin=0 hmax=1000 zmin=0. \ + >>> zmax=1. +.fi + +5. Modal filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the mode computing process using a circular +filter of outer radius 5.0. + +.nf + im> frmode dev$pix output 0.0 5.0 hmin=-1 hmax=20000 zmin=-1.0 \ + >>> zmax=20000 zloreject=5 zhireject=20000 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 39 and 27 CPU seconds to modal filter a +512 by 512 square integer image with a circular filter of radius 5 pixels +and a ring filter of inner and outer radii of 4.0 and 5.0 pixels +respectively (SPARCStation2). + +.ih +BUGS +This technique is most suitable for integer data and data which has not +been calibrated. For non-integer data the calculated median is an +approximation only. + +If the dynamic range of the data defined by hmin and hmax is large the +memory requirements can become very large. + +.ih +SEE ALSO +mode, rmode, fmode +.endhelp diff --git a/pkg/images/imfilter/doc/gauss.hlp b/pkg/images/imfilter/doc/gauss.hlp new file mode 100644 index 00000000..efbf17d4 --- /dev/null +++ b/pkg/images/imfilter/doc/gauss.hlp @@ -0,0 +1,162 @@ +.help gauss Jan91 images.imfilter +.ih +NAME +gauss -- convolve a list of images with an elliptical Gaussian function +.ih +USAGE +gauss input output sigma +.ih +PARAMETERS +.ls input +List of images to be convolved with the elliptical Gaussian function. +.le +.ls output +List of output images. The number of output images must equal the number of +input images. If the input image name equals the output image name, the +convolved image will replace the input image. +.le +.ls sigma +The sigma of the Gaussian function in pixels along the direction \fItheta\fR +of the major axis of the Gaussian function. +.le +.ls ratio = 1. +The ratio of the sigma in the minor axis direction to the sigma in the major +axis direction of the Gaussian function. +If \fIratio\fR is 1 the Gaussian function is circular. +.le +.ls theta = 0. +The position of the major axis of the elliptical Gaussian function. +\fITheta\fR is measured counter-clockwise from the x axis and must be between +0 and 180 degrees. +.le +.ls nsigma = 4.0 +The distance along the major axis of the Gaussian function at which +the kernel is truncated in \fIsigma\fR pixels. +.le +.ls bilinear = yes +Use the fact that the Gaussian function is separable (bilinear) in x and y if +\fItheta\fR = 0, 90, or 180, to compute the 2D convolution more efficiently? +\fIBilinear\fR is always set to "no" internally, if the position angle of +the major axis of the Gaussian is other than 0, 90 or 180 degrees. +.le +.ls boundary = "nearest" +The algorithm used to compute the values of the out of bounds pixels. The +options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The constant for constant-valued boundary extension. +.le + +.ih +DESCRIPTION + +GAUSS convolves the list of images in \fIinput\fR with the +Gaussian kernel specified by \fIsigma\fR, \fIratio\fR, \fItheta\fR and +\fInsigma\fR and places the convolved images in \fIoutput\fR. +If the image names in \fIinput\fR equal the image names in \fIoutput\fR +the convolution is performed in place and the original images are +overwritten. Out of bounds pixels are computed using the algorithm +specified by \fIboundary\fR. + +If \fIbilinear\fR is "yes" and the major axis of the Gaussian kernel +is aligned along either the x or y axis, GAUSS uses the fact that +the Gaussian function is mathematically separable (bilinear) in x and y +to speed up the convolution process. A bilinear 2D convolution kernel +in x and y is one which can be separated into two equivalent 1D +convolution kernels in x and y respectively. + +Although the bilinear approximation and the full 2D convolution are +mathematically equivalent, the user will actually see SMALL differences +between an image convolved with the full 2D kernel and the same image +convolved with the equivalent bilinear kernel. +These differences are the result of the finite size of the convolution kernel +(the integration does not extend to infinity in either direction), +and the fact that off-axis kernel elements outside the \fInsigma\fR limit +cannot be set to 0 in the bilinear case as they are in the full 2D +case. Therefore the bilinear kernel is less radially symmetric than +the full 2D kernel. In most cases the differences are small and more +than made up for by the greatly decreased execution time. + +The Gaussian kernel has an elliptical cross-section and Gaussian +profile and is defined mathematically as follows. + +.nf +1. Circularly Symmetric Gaussian Function + + ratio = 1 theta = 0.0 N = normalization factor + + G = N * exp (-0.5 * (r / sigma) ** 2) + +2. Elliptical Gaussian Function (Theta = 0, 90 or 180) + + sigmax = sigma sigmay = ratio * sigmax N = normalization factor + + A = cos (theta) ** 2 / sigmax ** 2 + sin (theta) ** 2 / sigmay ** 2 + + B = 0.0 + + C = sin (theta) ** 2 / sigmax ** 2 + cos (theta) ** 2 / sigmay ** 2 + + z = A * x ** 2 + B * x * y + C * y ** 2 + + G = N * exp (-0.5 * z) + +3. Elliptical Gaussian Function (Arbitrary Theta) + + sigmax = sigma sigmay = ratio * sigmax N=normalization factor + + A = cos (theta) ** 2 / sigmax ** 2 + sin (theta) ** 2 / sigmay ** 2 + + B = 2 * (1 / sigmax ** 2 - 1 / sigmay ** 2) * sin (theta) * cos (theta) + + C = sin (theta) ** 2 / sigmax ** 2 + cos (theta) ** 2 / sigmay ** 2 + + z = A * x ** 2 + B * x * y + C * y ** 2 + + G = N * exp (-0.5 * z) +.fi + +.ih +EXAMPLES + +1. Convolve an image with a circular Gaussian function of sigma 2.0, and +size 4.0 sigma using nearest neighbor boundary extension and the bilinear +kernel. + + cl> gauss m83 m83.gau 2.0 + +2. Do the same convolution using the full 2D kernel. + + cl> gauss m83 m83.gau.2D 2.0 bilinear- + +3. Convolve an image with an elliptical Gaussian function whose sigma in the +major and minor axis direction is 2.0 and 1.5 respectively, and whose position +angle is 45 degrees, using wrap around boundary extension. In this case the +full 2D kernel is used by default. + + cl> gauss m84 m84.gau 2.0 ratio=.75 theta=45. bound=wrap + +.ih +TIME REQUIREMENTS +GAUSS requires approximately 30 and 8 cpu seconds to +convolve a 512 square real image with circularly symmetric Gaussian function +of sigma 2 pixels, using the full 2D kernel and the bilinear +kernel respectively, on a Sparc Station 1. +.ih +BUGS +.ih +SEE ALSO +convolve, gradient, laplace, boxcar +.endhelp diff --git a/pkg/images/imfilter/doc/gradient.hlp b/pkg/images/imfilter/doc/gradient.hlp new file mode 100644 index 00000000..1bf1a152 --- /dev/null +++ b/pkg/images/imfilter/doc/gradient.hlp @@ -0,0 +1,170 @@ +.help gradient Nov85 images.imfilter +.ih +NAME +gradient -- convolve a list of images with the gradient filter +.ih +USAGE +gradient input output gradient +.ih +PARAMETERS +.ls input +List of images for which gradient images are to be calculated. +.le +.ls output +List of output images. The number of output images must equal the number of +input images. If the input image name equals the output image name the +convolved image will replace the input image. +.le +.ls gradient +The gradient filters are a set of 8 three by three kernels identified by the +angle of maximum response as measured counter-clockwise to the x axis. The +kernels approximate the gradient operator, which is defined as the slope of +the intensity distribution in an image. The eight supported gradient +operators are listed below. +.ls "0", "180" +Calculate the gradient image along a 0 or 180 degree angle. +These options approximate the d/dx operator. +Option "0" produces a maximum response for pixel values which +increase with increasing x, whereas option "180" produces a maximum +response for pixel values which decrease with increasing x. +.le +.ls "90", "270" +Calculate the gradient image along a 90 or 270 degree angle. +These options approximate the d/dy operator. +Option "90" produces a maximum response for pixel values which +increase with increasing y, whereas option "270" produces a maximum +response for pixel values which decrease with increasing y. +.le +.ls "45", "225" +Calculate the gradient image along a 45 or 225 degree angle. +Option "45" produces a maximum response for pixel values which increase +along a line at 45 degrees counter-clockwise to the x axis. +Option "225" produces +a maximum response for pixel values which increase along a line at 225 +degrees to the x axis. +.le +.ls "135", "315" +Calculate the gradient image along a 135 or 315 degree angle. +Option "135" produces a maximum response for pixel values which increase +along a line at 135 degrees counter-clockwise to the x axis. +Option "315" produces +a maximum response for pixel values which increase along a line at 315 +degrees to the x axis. +.le +.le +.ls boundary = "nearest" +The algorithm used to compute the values of out of bounds pixels. The +options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The constant for constant-valued boundary extension. +.le + +.ih +DESCRIPTION + +GRADIENT convolves the list of images specified by \fIinput\fR with one of +eight three by three gradient kernels specified by \fIgradient\fR +and places the output images in \fIoutput\fR. +If the image names in \fIoutput\fR equal the image names in \fIinput\fR the +gradient operation is performed in place and the original images are +overwritten. Out of bounds pixels are computed using the algorithm +specified by \fIboundary\fR. + +GRADIENT acts like a simple edge detector or high pass filter which is sensitive +to both the magnitude and direction of changes in intensity in an image. +For example, if an image's pixel values are specified by the sum of their +x and y coordinates (z = x + y) and boundary extension effects are ignored, +the "0", "45", "90", "135", "180", "225", "270", and "315" gradient kernels +will each produce a constant image containing the numbers 1, sqrt (2), 1, 0, +-1, -sqrt (2), -1, and 0 respectively. + +The eight gradient filters are listed below. The I[*,*] are the elements of +the input image and the O[*,*] are elements of the output image. + +.nf + 0 + + - I[-1,1] + 0*I[0,1] + I[1,1] + O[0,0] = - I[-1,0]*sqrt(2) + 0*I[0,0] + I[1,0] * sqrt(2) + - I[-1,-1] + 0*I[0,-1] + I[-1,-1] + + 45 + + + I[-1,1]*0 + I[0,1] + I[1,1]/2/sqrt(2) + O[0,0] = - I[-1,0] + I[0,0]*0 + I[1,0] + - I[-1,-1]/2/sqrt(2) - I[0,-1] + I[1,-1]*0 + + 90 + + + I[-1,1] + I[0,1]*sqrt(2) + I[1,1] + O[0,0] = + I[-1,0]*0 + I[0,0]*0 + I[1,0] + - I[-1,-1] - I[0,-1]*sqrt(2) - I[-1,-1] + + 135 + + + I[-1,1]/2/sqrt(2) + I[0,1] + I[1,1]*0 + O[0,0] = + I[-1,0] + I[0,0]*0 - I[1,0] + + I[-1,-1]*0 - I[0,-1] - I[1,-1]/2/sqrt(2) + + 180 + + + I[-1,1] + 0*I[0,1] - I[1,1] + O[0,0] = + I[-1,0]*sqrt(2) + 0*I[0,0] - I[1,0]*sqrt(2) + + I[-1,-1] + 0*I[0,-1] - I[-1,-1] + + 225 + + + I[-1,1]*0 - I[0,1] - I[1,1]/2/sqrt(2) + O[0,0] = + I[-1,0] + I[0,0]*0 - I[1,0] + + I[-1,-1]/2/sqrt(2) + I[0,-1] + I[1,-1]*0 + + 270 + + - I[-1,1] - I[0,1]*sqrt(2) - I[1,1] + O[0,0] = + I[-1,0]*0 + I[0,0]*0 + I[1,0]*0 + + I[-1,-1] + I[0,-1]*sqrt(2) + I[-1,-1] + + 315 + + - I[-1,1]/2/sqrt(2) - I[0,1] + I[1,1]*0 + O[0,0] = - I[-1,0] + I[0,0]*0 + I[1,0] + + I[-1,-1]*0 + I[0,-1] + I[1,-1]/2/sqrt(2) + +.fi + +.ih +EXAMPLES + +1. Calculate the gradient in the 180 degree direction using nearest neighbor + boundary extension. + +.nf + cl> gradient m83 m83.odeg 180 +.fi + +.ih +TIME REQUIREMENTS + +GRADIENT requires approximately 2.0 cpu seconds to convolve a +512 square real image with a 3 by 3 gradient kernel on a Sparc Station 1. + +.ih +BUGS + +.ih +SEE ALSO +convolve, gauss, laplace, boxcar +.endhelp diff --git a/pkg/images/imfilter/doc/laplace.hlp b/pkg/images/imfilter/doc/laplace.hlp new file mode 100644 index 00000000..3eb5c63c --- /dev/null +++ b/pkg/images/imfilter/doc/laplace.hlp @@ -0,0 +1,132 @@ +.help laplace Dec85 images.imfilter +.ih +NAME +laplace -- convolve a list of images with a Laplacian filter +.ih +USAGE +laplace input output +.ih +PARAMETERS +.ls input +List of images to be convolved. +.le +.ls output +List of output images. The number of output images must equal the number of +input images. If the input image name equals the output image name the +convolved image will replace the input image. +.le +.ls laplace = "xycentral" +The Laplacian filters are a set of four three by three kernels which +approximate the Laplacian operator, where a Laplacian operator is defined +as the sum of the partial second derivatives in x and y. +The elements of the four Laplacian kernels are shown in detail below. +.ls xycentral +The elements of the central column and row of a 3 by 3 image subraster are +combined to estimate the Laplacian at the position of the central pixel. +.le +.ls diagonals +The elements of the two diagonals of a 3 by 3 image subraster are combined +to estimate the Laplacian at the position of the central pixel. +.le +.ls xyall +The three columns and rows of a three by three image subraster are averaged +to estimate the Laplacian at the position of the central pixel. +.le +.ls xydiagonals +The central row and column and the two diagonals of a three by three image +subraster are combined to estimate the Laplacian at the position of the +central pixel. +.le +.le +.ls boundary = "nearest" +The algorithm used to compute the values of the out of bounds pixels. +The options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The constant for constant-valued boundary extension. +.le + +.ih +DESCRIPTION + +LAPLACE convolves the list of images specified by \fIinput\fR with one of +four 3 by 3 Laplacian kernels specified by \fIlaplace\fR +and places the convolved images in \fIoutput\fR. If the image names +in \fIoutput\fR equal the image names in \fIinput\fR the Laplacian +operation is performed in place and the original images are overwritten. +Out of bounds pixels are computed using the algorithm specified by +\fIboundary\fR. + +The Laplacian filters are high-pass filters which act as a local edge detector. +A characteristic of the Laplacian is that it is zero at points where the +gradient is a maximum or a minimum. Therefore points detected as gradient +edges would generally not be detected as edge points with the Laplacian +filter. Another characteristic of Laplacian operators is that a single +grey level transition may produce two distinct peaks one positive and +one negative in the Laplacian which may be offset from the gradient location. + +The four Laplacian filters are listed below. The I[*,*] are the elements of the +input image and the O[*,*] are the elements of the output image. + +.nf + xycenter + + 0*I[-1,1] + 1*I[0,1] + 0*I[1,1] + + O[0,0] = 1*I[-1,0] - 4*I[0,0] + 1*I[1,0] + + 0*I[-1,-1] + 1*I[0,-1] + 0*I[1,-1] + + + diagonals + + I[-1,1]/sqrt(2) + I[0,1]*0 + I[1,1]/sqrt(2) + +O[0,0] = I[-1,0]*0 - I[0,0]*4/sqrt(2) + I[1,0]*0 + + I[-1,-1]/sqrt(2) + I[0,-1]*0 + I[1,-1]/sqrt(2) + + xyall + + 2/3*I[-1,1] - 1/3*I[0,1] + 2/3*I[1,1] + + O[0,0] = - 1/3*I[-1,0] - 4/3*I[0,0] - 1/3*I[1,0] + + 2/3*I[-1,-1] - 1/3*I[0,-1] + 2/3*I[1,-1] + + xydiagonals + + I[-1,1]/sqrt(2)/2 + I[0,1]/2 + I[1,1]/sqrt(2)/2 + +O[0,0] = I[-1,0]/2 - I[0,0]*(2-sqrt(2)) + I[1,0]/2 + + I[-1,-1]/sqrt(2)/2 + I[0,-1]/2 + I[1,-1]/sqrt(2) + +.fi + +.ih +EXAMPLES + +1. Convolve an image with the Laplacian filter xyall using nearest neighbor +boundary extension. + + cl> laplace m83 m83.lap xyall + +.ih +TIME REQUIREMENTS + +LAPLACE requires approximately 1.7 cpu seconds to convolve a +512 square real image with a 3 by 3 Laplacian kernel on a Sparc +Station 1. + +.ih +BUGS + +.ih +SEE ALSO +convolve, gauss, gradient, boxcar +.endhelp diff --git a/pkg/images/imfilter/doc/median.hlp b/pkg/images/imfilter/doc/median.hlp new file mode 100644 index 00000000..5381611f --- /dev/null +++ b/pkg/images/imfilter/doc/median.hlp @@ -0,0 +1,109 @@ +.help median May95 images.imfilter +.ih +NAME +median -- median filter a list of images +.ih +USAGE +median input output xwindow ywindow +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as +the number of output images. If the input image name is the same as the +output image name the original image is replaced by the filtered image. +.le +.ls xwindow, ywindow +The size of the median filter. Xwindow and ywindow are assumed to be +odd integers. If either xwindow or ywindow are even they will be rounded +up to the nearest odd integer. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default to +-MAX_REAL and MAX_REAL respectively. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant value boundary extension. +.le + +.ih +DESCRIPTION + +MEDIAN takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The median filter consists of a sliding +rectangular window of dimensions \fIxwindow\fR +by \fIywindow\fR. The center pixel in the window is replaced by the median +of all the pixels in the +window, where the median of a sequence of numbers is defined to be the value +of the (n + 1) /2 pixel. If even the window dimensions are rounded up +to odd integers. Out of bounds +pixel references are handled by setting the parameter \fIboundary\fR. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to reject +bad data from the median filtering box. If no good +data is left in the filtering box, the median is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +EXAMPLES + +1. Median filter an image using a 5 by 5 window and nearest pixel boundary +extension. + +.nf + im> median m74 m74.5by5 5 5 +.fi + +2. Median filter an image using a 3 by 3 window and constant boundary extension. + +.nf + im> median m74 m74.5by5 3 3 boun=const const=0. +.fi + +3. Median filter the test image dev$pix, removing all pixels less than 5 or +greater than 19935 from the filtering box. + +.nf + im> median dev$pix pix77 7 7 zlo=5 zhi=19935 +.fi + +.ih +TIME REQUIREMENTS + +Median requires approximately 11 and 19 CPU seconds to filter a 512 by +512 integer image using a 5 by 5 and 7 by 7 filter window respectively +(SPARCStation2). + +.ih +BUGS + +The sort routine for the smaller kernels has been optimized. It may be +desirable to optimize higher order kernels in future. + +The IRAF task FMEDIAN is significantly more efficient than MEDIAN +and should be used if the image is integer or can be quantized without +significant loss of precision. + +.ih +SEE ALSO + +fmedian, rmedian, frmedian +.endhelp diff --git a/pkg/images/imfilter/doc/mode.hlp b/pkg/images/imfilter/doc/mode.hlp new file mode 100644 index 00000000..37f807e1 --- /dev/null +++ b/pkg/images/imfilter/doc/mode.hlp @@ -0,0 +1,119 @@ +.help mode May95 images.imfilter +.ih +NAME +mode -- modal filter a list of images +.ih +USAGE +mode input output xwindow ywindow +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as +the number of output images. If the input image name is the same as the +output image name the original image is replaced by the filtered image. +.le +.ls xwindow, ywindow +The size of the modal filter. Xwindow and ywindow are assumed to be +odd integers. Even values will be rounded up to the nearest odd integer. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good data values. Zloreject and zhireject default +to -MAX_REAL and MAX_REAL respectively. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant value boundary extension. +.le + +.ih +DESCRIPTION + +MODE takes a list of input images \fIinput\fR and produces a set of filtered +output images \fIoutput\fR. The modal filter consists of a sliding +rectangular window of dimensions \fIxwindow\fR +by \fIywindow\fR. The center pixel of the window is replaced by the mode +of all the pixels in the window where the mode of a sequence of numbers +is defined below. + +.nf + mode = 3. * median - 2. * mean +.fi + +The median of a sequence of pixels is defined as the value of the +(n + 1) / 2 number in the ordered sequence. +Out of bounds pixel references are handled by setting the parameter +\fIboundary\fR. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to reject +bad data from the modal filtering box. If no good +data is left in the filtering box, then the mode is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +A derivation of the expression for the mode used here can be found in +"Statistics in Theory and Practice", Robert Lupton, 1993, Princeton +University Press, problem 2. + +.ih +EXAMPLES + +1. Modal filter an image using a 5 by 5 window and nearest pixel boundary +extension. + +.nf + im> mode m74 m74.5by5 5 5 +.fi + +2. Modal filter an image using a 3 by 3 window and constant boundary +extension. + +.nf + im> mode m74 m74.5by5 3 3 boun=const const=0. +.fi + +3. Modal filter the test image, rejecting pixels < 5 and > 19935 from the +modal filter. + +.nf + im> mode dev$pix pix77 7 7 zlo=5 zhi=19935 +.fi + +.ih +TIME REQUIREMENTS + +Mode requires approximately 11 and 19 CPU seconds to filter a 512 by +512 integer image using a 5 by 5 and 7 by 7 filter window respectively +(SPARCStation2). + +.ih +BUGS + +The sort routine for the smaller kernels has been optimized. It may be +desirable to optimize higher order kernels in future. + +The IRAF task FMODE is significantly more efficient than MODE +and should be used if the data can be quantized. +.ih +SEE ALSO +fmode, rmode, frmode +.endhelp diff --git a/pkg/images/imfilter/doc/rmedian.hlp b/pkg/images/imfilter/doc/rmedian.hlp new file mode 100644 index 00000000..a37df6de --- /dev/null +++ b/pkg/images/imfilter/doc/rmedian.hlp @@ -0,0 +1,127 @@ +.help rmedian May95 images.imfilter +.ih +NAME +rmedian -- ring median filter a set of IRAF images +.ih +USAGE +rmedian input output rinner router +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as the +number of output images. If the input image name equals the output image name +the filtered images replaces the original image. +.le +.ls rinner, router +The inner and outer semi-major axes of the ring filter in pixels. If rinner +is set to 0.0 then the ring filter becomes a circular filter. +.le +.ls ratio = 1.0 +The ratio of the semi-minor axis to the semi-major axis of the ring filter. +If ratio is 1.0 the ring filter is circularly symmetric. +.le +.ls theta = 0.0 +The position angle of the major axis of the ring filter. Theta is measured +in degrees counter-clockwise from the x axis and must be between 0 and 180 +degrees. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to -MAX_REAL and MAX_REAL respectively. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le +.ih +DESCRIPTION + +RMEDIAN takes a list of input images \fIinput\fR and produces a list of +filtered +images \fIoutput\fR. The filter consists of a sliding circular / elliptical or +annular circular / elliptical window whose size and orientation is determined +by the \fIrinner\fR, \fIrouter\fR, \fIratio\fR, and \fItheta\fR parameters. +The center pixel in the window is replaced by the median of the pixels in the +window, where the median of a sequence of numbers is defined to be +the value of the (n + 1) / 2 pixel of the ordered sequence. +Out of bounds pixel references are handled by setting the parameter +\fIboundary\fR. The principal function of the circular / elliptical filter +is to smooth and image using a circularly / elliptically symmetric filter. +The principal function of the circular / elliptical ring filter is to +remove objects from the image which have a scale length of rinner and +replace them with an estimate of the local background value. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to +reject bad data from the median filtering box. If no good +data is left in the filtering box, then the median is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +The properties of the ring median filter and its application to +astronomical data analysis problems is summarized in the +article "A Ring Median Filter for Digital Images" (Secker, J., 1995, +PASP, 107, 496-501) and references therein. + +A derivation of the expression for the mode used here can be found in +"Statistics in Theory and Practice", Robert Lupton, 1993, Princeton +University Press, problem 2. + +.ih +EXAMPLES + +1. Median filter an image using a circular ring filter with an inner +radius of 4 pixels and a width of 1 pixel. + +.nf + im> rmedian input output 4.0 5.0 +.fi + +2. Median filter an image using a circular ring filter of outer +radius 3. + +.nf + im> rmedian input output 0.0 3.0 +.fi + +3. Median filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the medianing process using a circular filter +of outer radius 5.0. + +.nf + im> rmedian dev$pix output 0.0 5.0 zloreject=5 zhireject=19935 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 59 and 35 CPU seconds to median filter a +512 by 512 square integer image with a circular filter of radius 5 pixels +and a ring filter of inner and outer radii of 4.0 and 5.0 pixels respectively. +(SPARCStation2). + +.ih +BUGS + +.ih +SEE ALSO +median, fmedian, frmedian +.endhelp diff --git a/pkg/images/imfilter/doc/rmode.hlp b/pkg/images/imfilter/doc/rmode.hlp new file mode 100644 index 00000000..4c366ab8 --- /dev/null +++ b/pkg/images/imfilter/doc/rmode.hlp @@ -0,0 +1,133 @@ +.help rmode May95 images.imfilter +.ih +NAME +rmode -- ring modal filter a list of images +.ih +USAGE +rmode input output rinner router +.ih +PARAMETERS +.ls input +List of input images. +.le +.ls output +List of filtered images. The number of input images must be the same as the +number of output images. If the input image name equals the output image name +the filtered image replaces the original image. +.le +.ls rinner, router +The inner and outer semi-major axes of the ring filter in pixels. If rinner +is set to 0.0 then the ring filter becomes a circular filter. +.le +.ls ratio = 1.0 +The ratio of the semi-minor axis to the semi-major axis of the ring filter. +If ratio is 1.0 the ring filter is circularly symmetric. +.le +.ls theta = 0.0 +The position angle of the major axis of the ring filter. Theta is measured +counter-clockwise in degrees from the x axis and must be between 0 and +180 degrees. +.le +.ls zloreject = INDEF, zhireject = INDEF +The minimum and maximum good pixel values. Zloreject and zhireject default +to -MAX_REAL and MAX_REAL respectively. +.le +.ls boundary = "nearest" +The type of boundary extension. The options are: +.ls nearest +Use the value of the nearest pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Reflect pixel values around the boundary. +.le +.ls wrap +Wrap pixel values around the boundary. +.le +.le +.ls constant = 0. +The value for constant valued boundary extension. +.le + +.ih +DESCRIPTION + +RMODE takes a list of input images \fIinput\fR and produces a list of +filtered +images \fIoutput\fR. The filter consists of a sliding circular / elliptical or +annular circular / elliptical window whose size and orientation is determined +by the \fIrinner\fR, \fIrouter\fR, \fIratio\fR, and \fItheta\fR parameters. +The center pixel in the window is replaced by the mode of the pixel +distribution where mode is defined below. + +.nf + mode = 3. * median - 2. * mean +.fi + +The median is defined as the value of the (n + 1) / 2 number in an ordered +sequence of numbers. +Out of bounds pixel references are handled by setting the parameter +\fIboundary\fR. The principal function of the circular / elliptical filter +is to smooth and image using a circularly / elliptically symmetric filter. +The principal function of the circular / elliptical ring filter is to +remove objects from the image which have a scale length of rinner and +replace them with an estimate of the local background value. + +The \fIzloreject\fR and \fIzhireject\fR parameters may be used to reject +bad data from the modal filtering box. If no good +data is left in a given filtering box, then the mode is set to zloreject +if the majority of the pixels are less than zloreject, or to zhireject +if the majority of pixels are greater than zhireject. + +.ih +REFERENCES + +The properties of the ring median filter and its application to +astronomical analysis problems is summarized in the +article "A Ring Median Filter for Digital Images" (Secker, J., 1995, +PASP, 107, 496-501) and references therein. + +A derivation of the expression for the mode used here can be found in +"Statistics in Theory and Practice", Robert Lupton, 1993, Princeton +University Press, problem 2. + +.ih +EXAMPLES + +1. Modal filter an image using a circular ring filter with an inner radius +of 4 pixels and a width of 1 pixel. + +.nf + cl> rmode input output 4.0 5.0 +.fi + +2. Modal filter an image using a circular filter of outer radius 3.0. + +.nf + cl> rmode input output 0.0 3.0 +.fi + +3. Modal filter the test image dev$pix rejecting any pixels < 5 or +greater than 19935 from the modal filter using a circular +filter of outer radius 5.0. + +.nf + im> rmode dev$pix output 0.0 5.0 zloreject=5 zhireject=19935 +.fi + +.ih +TIME REQUIREMENTS +It requires approximately 59 and 35 CPU seconds to modal filter a +512 by 512 square integer image with a circular filter of radius 5 pixels +and a ring filter of inner and outer radii of 4.0 and 5.0 pixels respectively. +(SPARCStation2). + +.ih +BUGS + +.ih +SEE ALSO +mode,fmode,rmode +.endhelp diff --git a/pkg/images/imfilter/doc/runmed.hlp b/pkg/images/imfilter/doc/runmed.hlp new file mode 100644 index 00000000..ed58f972 --- /dev/null +++ b/pkg/images/imfilter/doc/runmed.hlp @@ -0,0 +1,206 @@ +.help runmed May05 images.imfilter +.ih +NAME +runmed -- running median filter a list of images +.ih +USAGE +runmed input output window +.ih +PARAMETERS +.ls input +List of input images. The list is used in the order provided without +sorting. All images must be the same dimensionality and size. There must +be at least three images. +.le +.ls output +List of output images. The number of output images must be the same as +the number of input images. If the input image name is the same as the +output image name the original image is replaced by the filtered image. +.le +.ls window +Number of images for the running window. This must be at least three, and +less than or equal to the number of images in the input list. +.le +.ls masks = "" +List of output masks indicating the number of pixels used in calculating the +filter value. If specified the list must match the output list. +.le +.ls inmaskkey = "" +Keyword in the input image containing a maskname for selecting or ignoring +pixels. Pixels to be used are selected by zero values in the mask. +.le +.ls outmaskkey = "HOLES" +Keyword in the output image to containing the name of the output mask. +If no output mask is created or if no keyword is specified then the +keyword is not added or replaced in the output image. +.le +.ls outtype = "filter" (filter|difference|ratio) +The type of output values in the images. The choices are "filter" for +the filter value, "difference" for the difference of the input and +filter value (input-filter), and "ratio" for the ratio of the input +and filter value (input/filter). +.le +.ls exclude = no +Exclude the input image from the filter. +.le +.ls nclip = 0. +This parameter allows clipping high values from the median calculation. +The value multiples the difference between the median and the lowest value +and rejects values that exceed the median by this amount. The is done +after scaling, mask rejections, and image exclusion. +.le +.ls navg = 1 +Number of central values to average. A value of 1 is used to compute +the median. +.le +.ls scale = "none" (none|mode|!|@) +Scale the images with the specified method. The choices are +"none", "mode" to compute a mode for each image and divide by the value, +"!" to find the value to multiple the image from the specified +keyword in the header, and "@" to get the values to multiple the +images from the specified file. The scales are normalized by the scale +for the first image to make the scaling relative to the first image. +The values in a file must be in the same order as the input images. +.le +.ls normscale = yes +Normalize the scales to the first image scale? +.le +.ls outscale = yes +Scale output images? If yes the output images will be on the system +defined by the input scale factors. If no the output is scaled back +to match the input levels. +.le +.ls blank = 0 +Filter value when all data have been excluded from the calculation. +.le +.ls storetype = "real" +Internal storage type which may be "real" or "short". The short +integer type saves memory at the cost of rounding. Unless memory +is a problem real storage is recommended. +.le +.ls verbose = yes +Print progress information to the standard output. +.le +.ih +DESCRIPTION +\fBRUNMED\fR takes a list of input images (\fIinput\fR) and produces +a set of filtered output images (\fIoutput\fR). The output images +are matched with the input images and the header of the output image +is that of the matching input image. The output image may be the +same as the input image if desired. + +Each input image may have an associated pixel mask. The mask is specified +by the keyword in the image specified by the \fIinmaskkey\fR parameter. +The masks must be of a matching size. This task matches mask pixel with +image pixels based on the logical pixel coordinates. In other words, it +does not take into account any subsection that may have been applied to the +input images which was not also applied to the mask images. A non-zero +mask value identifies pixels to be excluded from the computation of the +filter value or the mode of the image. + +The input images may be scaled (\fIscale\fR) as they are read. +The scale factors may be normalized relative to the first image in the +list (\fInormscale\fR). The scale factors may be given explicitly in a +file or keyword or computed from an estimate of the mode of the image. +The mode computation excludes pixels identified by non-zero values in +the associated input mask. On output the computed filter value based +on the set of scaled pixel values maybe scaled back to match that of +the input image (\fIoutscale\fR). + +The running filter operates independently on the sequence of pixel +values across the list of input images at each pixel position. If an +input mask is specified then non-zero mask values identify pixel values +to exclude from the calculations. The \fIexclude\fR parameter may be +used to exclude the central image of the window. This is useful to +avoid unnatural histograms with a spike at for the output image. +The filter sorts the sequence of unrejected values in a running window +(\fIwindow\fR). + +The median is the central value when the number of unrejected values is +odd and the average of the two central values. This median may be used +with the \fInclip\fR parameter to exclude high outliers in the sorted +values at each point. The clipping computes the difference between +the median and the lowest value, multiplies by the clipping factor, +and rejects values more than this threshold above the median. This is +only done when \fInclip\fR is greater than zero and there are at least +3 unrejected values prior to this clipping step. + +After the clipping the average, as set by \fInavg\fR, of the central values +is computed. Note that an average of one is a median. + +The number of central values averaged will be even when the number of +pixels is even and odd when it is odd. What is done is that high +and low values are excluded symmetrically until the number of remaining +pixels is less than or equal to the specified average but with at least +one or two values remaining. + +The number of values available to the average is odd when no data is +excluded because the window size must be odd. When the \fIexclude\fR +parameter is selected the number of values will be even. And when pixel +masks are used the number be anywhere from zero to the window size. +When all pixels are excluded the filter value is the \fIblank\fR value. +Also when the ratio output is selected and the filter value used as the +denominator is zero the \fIblank\fR value is also used. + +The output of this task are images of the filter values +(\fIouttype\fR="filter"), the difference of the input image and the +filter value (\fIouttype\fR="difference"), or the ratio of the input +image and the filter value (\fIouttype\fR="ratio"). The difference +output is useful as a background subtraction for a background that varies +systematically through the list of images. When the difference +is selected the input and filter value are matched by their scale factors +either in the scaled system (\fIoutscale\fR=yes) or in the input +system (\fIoutscale\fR=no). + +The \fIexclude\fR option is useful for the background subtraction case. +Use of this option excludes the input image from the to the filter +computation value for the matching output. This insures that the output +pixel value histogram does not have a spike of zero values when \fInavg\fR += 1 and the median pixel value is that of the input image. + +An output mask list (\fImasks\fR) may be specified to produce masks which +contain the number of pixels used in computing the filter value. This +is most useful to define regions where no pixels were used and the +blank value was substituted. The name of the output mask is recorded +in the output image header under the keyword specified by the +\fIoutmaskkey\fR parameter. Note that it is valid to specify the +output mask keyword to be the same as the input mask keyword. If this +is not done the input mask keyword, if present, will remain in the +output header. + +Normally the filter window is centered on each input image within the list. +In other words there are an equal number of images before and after the +input image taken from the input list. However, at the beginning and end +of the input list, the window spans the first or last \fIwindow\fR images. +The filter value will then be the same except that the \fIexclude\fR +option applies to the particular input image and the difference and +ratio output types will be based on the particular input image. + +This task is designed to be as efficient as possible so that images +are read only once (or twice if the mode is computed) and added to an +optimized tree algorithm to avoid completely resorting data as each new +image is read. In order to do this it buffers pixel data internally as +well as having some memory overhead from the tree algorithm. The memory +is compressed as much as possible. The amount of memory required will +scale with the size of the window, the number of pixels in the images, +and the storage datatype. The storage datatype (\fIstoretype\fR) may be +short integer, which is two bytes per pixel, and real, which is four bytes +per pixel. If memory limitations are an issue one may chose to use short +storage which requires of order 75% less memory. The tradeoff is that +data will be rounded (not truncated). In many cases this effect +will be minor. Note that even if the input data is integer the pixels +values may be scaled resulting in fractional scaled values. The output +images will be real regardless of the input type. + +With sufficiently large images and large windows it is possible this task +will fail to run requiring the user to make adjustments. The simplest +method would be to break the images into smaller pieces and run this task +on each piece. Note that input image sections can be used to reduce the +size of the input images being processed and \fBimtile\fR +can be use to piece the output back together. +.ih +EXAMPLES +.ih +SEE ALSO +imcombine, rskysub, irproc +.endhelp diff --git a/pkg/images/imfilter/fmedian.par b/pkg/images/imfilter/fmedian.par new file mode 100644 index 00000000..13ca273d --- /dev/null +++ b/pkg/images/imfilter/fmedian.par @@ -0,0 +1,17 @@ +# Parameters for the FMEDIAN task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output images +xwindow,i,a,,,,X window size of median filter +ywindow,i,a,,,,Y window size of median filter +hmin,i,h,-32768,,,Minimum histogram bin +hmax,i,h,32767,,,Maximum histogram bin +zmin,r,h,INDEF,,,Pixel value corresponding to hmin +zmax,r,h,INDEF,,,Pixel value corresponding to hmax +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +unmap,b,h,yes,,,Unmap the digitized values ? +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task +mode,s,h,'ql' diff --git a/pkg/images/imfilter/fmode.par b/pkg/images/imfilter/fmode.par new file mode 100644 index 00000000..7244243f --- /dev/null +++ b/pkg/images/imfilter/fmode.par @@ -0,0 +1,17 @@ +# Parameters for the FMODE task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output images +xwindow,i,a,,,,X window size of modal filter +ywindow,i,a,,,,Y window size of modal filter +hmin,i,h,-32768,,,Minimum histogram bin +hmax,i,h,32767,,,Maximum histogram bin +zmin,r,h,INDEF,,,Pixel value corresponding to hmin +zmax,r,h,INDEF,,,Pixel value corresponding to hmax +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +unmap,b,h,yes,,,Unmap the digitized values ? +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task +mode,s,h,'ql' diff --git a/pkg/images/imfilter/frmedian.par b/pkg/images/imfilter/frmedian.par new file mode 100644 index 00000000..9c1f2df3 --- /dev/null +++ b/pkg/images/imfilter/frmedian.par @@ -0,0 +1,19 @@ +# Parameters for the FRMEDIAN task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output filtered images +rinner,r,a,0.0,,, The inner radius of the elliptical ring filter +router,r,a,,,,The outer radius of the elliptical ring filter +ratio,r,h,1.0,0.0,1.0,Ratio of minor to major axes +theta,r,h,0.0,0.0,180.0,Position angle of elliptical ring filter +hmin,i,h,-32768,,,Minimum histogram bin +hmax,i,h,32767,,,Maximum histogram bin +zmin,r,h,INDEF,,,Pixel value corresponding to hmin +zmax,r,h,INDEF,,,Pixel value corresponding to hmax +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +unmap,b,h,yes,,,Unmap the digitized values ? +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task +mode,s,h,'ql' diff --git a/pkg/images/imfilter/frmode.par b/pkg/images/imfilter/frmode.par new file mode 100644 index 00000000..35fe2210 --- /dev/null +++ b/pkg/images/imfilter/frmode.par @@ -0,0 +1,19 @@ +# Parameters for the FRMODE task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output filtered images +rinner,r,a,0.0,,, The inner radius of the elliptical ring filter +router,r,a,,,,The outer radius of the elliptical ring filter +ratio,r,h,1.0,0.0,1.0,Ratio of minor to major axes +theta,r,h,0.0,0.0,180.0,Position angle of elliptical ring filter +hmin,i,h,-32768,,,Minimum histogram bin +hmax,i,h,32767,,,Maximum histogram bin +zmin,r,h,INDEF,,,Pixel value corresponding to hmin +zmax,r,h,INDEF,,,Pixel value corresponding to hmax +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +unmap,b,h,yes,,,Unmap the digitized values ? +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task +mode,s,h,'ql' diff --git a/pkg/images/imfilter/gauss.par b/pkg/images/imfilter/gauss.par new file mode 100644 index 00000000..db92e5d5 --- /dev/null +++ b/pkg/images/imfilter/gauss.par @@ -0,0 +1,12 @@ +# GAUSSIAN FILTER + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +sigma,r,a,,,,Sigma of Gaussian along major axis of ellipse +ratio,r,h,1.0,0.0,1.0,Ratio of sigma in y to x +theta,r,h,0.0,0.0,180.0,Position angle of ellipse +nsigma,r,h,4.0,,,Extent of Gaussian kernel in sigma +bilinear,b,h,yes,,,Use bilinear approximation to Gaussian kernel +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +mode,s,h,'ql' diff --git a/pkg/images/imfilter/gradient.par b/pkg/images/imfilter/gradient.par new file mode 100644 index 00000000..bf6bae01 --- /dev/null +++ b/pkg/images/imfilter/gradient.par @@ -0,0 +1,8 @@ +# GRADIENT FILTER + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +gradient,s,a,,,,'Gradient filter (0,45,90,135,180,225,270,315)' +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +mode,s,h,'ql' diff --git a/pkg/images/imfilter/imfilter.cl b/pkg/images/imfilter/imfilter.cl new file mode 100644 index 00000000..bc4df99e --- /dev/null +++ b/pkg/images/imfilter/imfilter.cl @@ -0,0 +1,24 @@ +#{ IMFILTER -- The Image Filtering Package. + +set imfilter = "images$imfilter/" + +package imfilter + +# Tasks. + +task boxcar, + convolve, + fmedian, + fmode, + frmedian, + frmode, + gauss, + gradient, + laplace, + median, + mode, + rmedian, + rmode, + runmed = "imfilter$x_images.e" + +clbye() diff --git a/pkg/images/imfilter/imfilter.hd b/pkg/images/imfilter/imfilter.hd new file mode 100644 index 00000000..cfb95cb0 --- /dev/null +++ b/pkg/images/imfilter/imfilter.hd @@ -0,0 +1,21 @@ +# Help directory for the IMFILTER package + +$doc = "images$imfilter/doc/" +$src = "images$imfilter/src/" + +boxcar hlp=doc$boxcar.hlp, src=src$t_boxcar.x +convolve hlp=doc$convolve.hlp, src=src$t_convolve.x +fmedian hlp=doc$fmedian.hlp, src=src$t_fmedian.x +fmode hlp=doc$fmode.hlp, src=src$t_fmode.x +frmedian hlp=doc$frmedian.hlp, src=src$t_frmedian.x +frmode hlp=doc$frmode.hlp, src=src$t_frmode.x +gauss hlp=doc$gauss.hlp, src=src$gauss.hlp +gradient hlp=doc$gradient.hlp, src=src$t_gradient.x +laplace hlp=doc$laplace.hlp, src=src$t_laplace.x +median hlp=doc$median.hlp, src=src$t_median.x +mode hlp=doc$mode.hlp, src=src$t_mode.x +rmedian hlp=doc$rmedian.hlp, src=src$t_rmedian.x +rmode hlp=doc$rmode.hlp, src=src$t_rmode.x +runmed hlp=doc$runmed.hlp, src=src$t_runmed.x +revisions sys=Revisions + diff --git a/pkg/images/imfilter/imfilter.men b/pkg/images/imfilter/imfilter.men new file mode 100644 index 00000000..1d85dc18 --- /dev/null +++ b/pkg/images/imfilter/imfilter.men @@ -0,0 +1,14 @@ + boxcar - Boxcar smooth a list of 1 or 2-D images + convolve - Convolve a list of 1 or 2-D images with a rectangular filter + fmedian - Quantize and box median filter a list of 1D or 2D images + fmode - Quantize and box modal filter a list of 1D or 2D images + frmedian - Quantize and ring median filter a list of 1D or 2D images + frmode - Quantize and ring modal filter a list of 1D or 2D images + gauss - Convolve a list of 1 or 2-D images with an elliptical Gaussian + gradient - Convolve a list of 1 or 2-D images with a gradient operator + laplace - Laplacian filter a list of 1 or 2-D images + median - Median box filter a list of 1D or 2D images + mode - Modal box filter a list of 1D or 2D images + rmedian - Ring median filter a list of 1D or 2D images + rmode - Ring modal filter a list of 1D or 2D images + runmed - Running median a list of images at each pixel position diff --git a/pkg/images/imfilter/imfilter.par b/pkg/images/imfilter/imfilter.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/imfilter/imfilter.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/imfilter/laplace.par b/pkg/images/imfilter/laplace.par new file mode 100644 index 00000000..7def4986 --- /dev/null +++ b/pkg/images/imfilter/laplace.par @@ -0,0 +1,8 @@ +# LAPLACE FILTER + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +laplace,s,h,xycent,,,'Laplacian filter (xycentral,diagonals,xyall,xydiagonals)' +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +mode,s,h,'ql' diff --git a/pkg/images/imfilter/median.par b/pkg/images/imfilter/median.par new file mode 100644 index 00000000..bd5cf8ef --- /dev/null +++ b/pkg/images/imfilter/median.par @@ -0,0 +1,12 @@ +# Parameters for the MEDIAN task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output images +xwindow,i,a,,,,X window size of median filter +ywindow,i,a,,,,Y window size of median filter +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task ? +mode,s,h,'ql' diff --git a/pkg/images/imfilter/mkpkg b/pkg/images/imfilter/mkpkg new file mode 100644 index 00000000..4bb23a53 --- /dev/null +++ b/pkg/images/imfilter/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMFILTER Package + +libpkg.a: + @src + ; diff --git a/pkg/images/imfilter/mode.par b/pkg/images/imfilter/mode.par new file mode 100644 index 00000000..3d4aa087 --- /dev/null +++ b/pkg/images/imfilter/mode.par @@ -0,0 +1,12 @@ +# Parameters for the MODE task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output images +xwindow,i,a,,,,X window size of mode filter +ywindow,i,a,,,,Y window size of mode filter +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task ? +mode,s,h,'ql' diff --git a/pkg/images/imfilter/rmedian.par b/pkg/images/imfilter/rmedian.par new file mode 100644 index 00000000..1aca43eb --- /dev/null +++ b/pkg/images/imfilter/rmedian.par @@ -0,0 +1,14 @@ +# Parameters for the RMEDIAN task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output filtered images +rinner,r,a,0.0,,, The inner radius of the elliptical ring filter +router,r,a,,,,The outer radius of the elliptical ring filter +ratio,r,h,1.0,0.0,1.0,Ratio of minor to major axes of the ring filter +theta,r,h,0.0,0.0,180.0,Position angle of elliptical ring filter +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task ? +mode,s,h,'ql' diff --git a/pkg/images/imfilter/rmode.par b/pkg/images/imfilter/rmode.par new file mode 100644 index 00000000..75a10d39 --- /dev/null +++ b/pkg/images/imfilter/rmode.par @@ -0,0 +1,14 @@ +# Parameters for the RMODE task + +input,f,a,,,,Input images to be filtered +output,f,a,,,,Output filtered images +rinner,r,a,0.0,,, The inner radius of the elliptical ring filter +router,r,a,,,,The outer radius of the elliptical ring filter +ratio,r,h,1.0,0.0,1.0,Ratio of minor to major axes of the ring filter +theta,r,h,0.0,0.0,180.0,Position angle of elliptical ring filter +zloreject,r,h,INDEF,,,Lowside pixel value cutoff +zhireject,r,h,INDEF,,,High side pixel value cutoff +boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +verbose,b,h,yes,,,Print messages about actions taken by the task ? +mode,s,h,'ql' diff --git a/pkg/images/imfilter/runmed.par b/pkg/images/imfilter/runmed.par new file mode 100644 index 00000000..80e25b01 --- /dev/null +++ b/pkg/images/imfilter/runmed.par @@ -0,0 +1,16 @@ +input,s,a,,,,List of input images +output,s,a,,,,List of output images +window,i,a,3,3,,Running window +masks,s,h,"",,,List of output masks +inmaskkey,s,h,"",,,Keyword for input masks +outmaskkey,s,h,"HOLES",,,Keyword for output masks +outtype,s,h,"filter","filter|difference|ratio",,Type of output values +exclude,b,h,no,,,Exclude input image from filter value? +nclip,r,h,0.,0.,,Clipping factor +navg,i,h,1,1,,Number of central values to average +scale,s,h,"none",,,Scaling option +normscale,b,h,yes,,,Normalize scales to first image? +outscale,b,h,no,,,Scale output? +blank,r,h,0.,,,Filter value when all pixels are excluded +storetype,s,h,"real","real|short",,Internal storage type +verbose,b,h,yes,,,Verbose? diff --git a/pkg/images/imfilter/src/aboxcar.x b/pkg/images/imfilter/src/aboxcar.x new file mode 100644 index 00000000..3cf32cdd --- /dev/null +++ b/pkg/images/imfilter/src/aboxcar.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CNV_ABOXR -- Vector boxcar smooth. + +procedure cnv_aboxr (in, out, npix, knpix) + +real in[npix+knpix-1] +real out[npix] +int npix, knpix + +int i +real sum + +begin + sum = 0.0 + do i = 1, knpix - 1 + sum = sum + in[i] + + do i = 1, npix { + sum = sum + in[i+knpix-1] + out[i] = sum + sum = sum - in[i] + } +end diff --git a/pkg/images/imfilter/src/boxcar.x b/pkg/images/imfilter/src/boxcar.x new file mode 100644 index 00000000..d7a58872 --- /dev/null +++ b/pkg/images/imfilter/src/boxcar.x @@ -0,0 +1,89 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CNV_BOXCAR -- Convolve an image. The kernel dimensions are assumed to +# be odd + +procedure cnv_boxcar (im1, im2, nxk, nyk, boundary, constant) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +int nxk, nyk # dimensions of the kernel +int boundary # type of boundary extnsion +real constant # constant for constant boundary extension + +int i, ncols, nlines, col1, col2, inline, outline +pointer sp, lineptrs, accum, outbuf + +pointer imgs2r(), impl2r() + +errchk imgs2r, impl2r + +begin + # Number of columns and lines of output image + ncols = IM_LEN(im2,1) + if (IM_NDIM(im2) == 1) + nlines = 1 + else + nlines = IM_LEN(im2,2) + + # Set input image column limits + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1,1) + nxk / 2 + + # Set up an array of linepointers and accumulators + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + call salloc (accum, ncols + nxk - 1, TY_REAL) + + # Set boundary conditions on input image + call imseti (im1, IM_NBUFS, nyk) + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2 + 1, nyk / 2 + 1)) + if (boundary == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Clear the accumulator + call aclrr (Memr[accum], ncols + nxk - 1) + + # Initialize the accumulator + inline = 1 - nyk / 2 + do i = 1, nyk - 1 { + Memi[lineptrs+i] = imgs2r (im1, col1, col2, inline, inline) + call aaddr (Memr[accum], Memr[Memi[lineptrs+i]], Memr[accum], + ncols + nxk - 1) + inline = inline + 1 + } + + # Generate the remaining image lines image line by line + do outline = 1, nlines { + + # Scroll buffers + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line, accumulate + Memi[lineptrs+nyk-1] = imgs2r (im1, col1, col2, inline, inline) + call aaddr (Memr[accum], Memr[Memi[lineptrs+nyk-1]], Memr[accum], + ncols + nxk - 1) + + # Write output image line + outbuf = impl2r (im2, outline) + if (outbuf == EOF) + call error (0, "Error writing output image.") + call cnv_aboxr (Memr[accum], Memr[outbuf], ncols, nxk) + call adivkr (Memr[outbuf], real (nxk * nyk), Memr[outbuf], ncols) + + # Subtract last line + call asubr (Memr[accum], Memr[Memi[lineptrs]], Memr[accum], + ncols + nxk - 1) + + inline = inline + 1 + } + + # Free buffers + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/convolve.x b/pkg/images/imfilter/src/convolve.x new file mode 100644 index 00000000..4517acd3 --- /dev/null +++ b/pkg/images/imfilter/src/convolve.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CNV_CONVOLVE -- Convolve an image with an nxk by nyk kernel. The kernel +# dimensions are assumed to be odd. + +procedure cnv_convolve (im1, im2, kernel, nxk, nyk, boundary, constant, radsym) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +real kernel[nxk,nyk] # the convolution kernel +int nxk, nyk # dimensions of the kernel +int boundary # type of boundary extension +real constant # constant for constant boundary extension +int radsym # does the kernel have radial symmetry ? + +int i, ncols, nlines, col1, col2, nincols, inline, outline +pointer sp, lineptrs, linebuf, outbuf +pointer imgs2r(), impl2r() +errchk imgs2r, impl2r + +begin + # Set up an array of line pointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Set the number of image buffers. + call imseti (im1, IM_NBUFS, nyk) + + # Set the input image boundary conditions. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2 + 1, nyk / 2 + 1)) + if (boundary == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the number of output image lines and columns. + ncols = IM_LEN(im2,1) + if (IM_NDIM(im2) == 1) + nlines = 1 + else + nlines = IM_LEN(im2,2) + + # Set the input image column limits. + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1,1) + nxk / 2 + nincols = col2 - col1 + 1 + + # Initialise the line buffers. + inline = 1 - nyk / 2 + do i = 1 , nyk - 1 { + Memi[lineptrs+i] = imgs2r (im1, col1, col2, inline, inline) + inline = inline + 1 + } + + # Generate the output image line by line + call salloc (linebuf, nincols, TY_REAL) + do outline = 1, nlines { + + # Scroll the input buffers + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line + Memi[lineptrs+nyk-1] = imgs2r (im1, col1, col2, inline, + inline) + + # Get output image line + outbuf = impl2r (im2, outline) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Generate output image line + call aclrr (Memr[outbuf], ncols) + if (radsym == YES) { + do i = 1, nyk / 2 { + call aaddr (Memr[Memi[lineptrs+i-1]], + Memr[Memi[lineptrs+nyk-i]], Memr[linebuf], nincols) + call cnv_radcnvr (Memr[linebuf], Memr[outbuf], ncols, + kernel[1,i], nxk) + } + if (mod (nyk, 2) == 1) + call cnv_radcnvr (Memr[Memi[lineptrs+nyk/2]], Memr[outbuf], + ncols, kernel[1,nyk/2+1], nxk) + } else { + do i = 1, nyk + call acnvr (Memr[Memi[lineptrs+i-1]], Memr[outbuf], ncols, + kernel[1,i], nxk) + } + + inline = inline + 1 + } + + # Free the image buffer pointers + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/fmd_buf.x b/pkg/images/imfilter/src/fmd_buf.x new file mode 100644 index 00000000..608a073d --- /dev/null +++ b/pkg/images/imfilter/src/fmd_buf.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# FMD_BUF -- Procedure to maintain a buffer of image lines. A new buffer +# is created when the buffer pointer is null or if the number of lines +# requested is changed. The minimum number of image reads is used. + +procedure fmd_buf (im, col1, col2, line1, line2, buf, map, a1, a2, b1, b2) + +pointer im #I pointer to image +int col1, col2 #I column limits in the image +int line1, line2 #I line limits in the image +pointer buf #U buffer pointer +int map #I perform mapping on image lines +real a1, a2 #I limits of input image line +real b1, b2 #I limits of output image line + + +int i +int ncols, nlines, llast1, llast2, nllast, nclast +pointer bufr, bufi, buf1, buf2 +bool fp_equalr() +pointer imgs2r(), imgs2i() +errchk imgs2r, imgs2i + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + # If the buffer pointer is undefined then allocate memory for the + # buffer. If the number of lines or columns changes then reallocate + # the buffer. Initialize the last line values to force a full + # buffer image read. + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_INT) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_INT) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + # Read in only image lines which are different from the last buffer. + if (line1 < llast1) { + do i = line2, line1, -1 { + buf2 = buf + (i - line1) * ncols + if (i >= llast1) { + buf1 = buf + (i - llast1) * ncols + call amovi (Memi[buf1], Memi[buf2], ncols) + } else { + if (map == YES) { + bufr = imgs2r (im, col1, col2, i, i) + if (fp_equalr (a1, a2)) + call amovkr (b1, Memr[bufr], ncols) + else + call amapr (Memr[bufr], Memr[bufr], ncols, a1, a2, + b1, b2) + call achtri (Memr[bufr], Memi[buf2], ncols) + } else { + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + bufi = imgs2i (im, col1, col2, i, i) + call amaxki (Memi[bufi], nint(a1), Memi[buf2], + ncols) + call aminki (Memi[buf2], nint(a2), Memi[buf2], + ncols) + default: + bufr = imgs2r (im, col1, col2, i, i) + if (fp_equalr (a1, a2)) + call amovkr (b1, Memr[bufr], ncols) + else + call amapr (Memr[bufr], Memr[bufr], ncols, a1, + a2, b1, b2) + call achtri (Memr[bufr], Memi[buf2], ncols) + } + } + } + } + } else if (line2 > llast2) { + do i = line1, line2 { + buf2 = buf + (i - line1) * ncols + if (i <= llast2) { + buf1 = buf + (i - llast1) * ncols + call amovi (Memi[buf1], Memi[buf2], ncols) + } else { + if (map == YES) { + bufr = imgs2r (im, col1, col2, i, i) + if (fp_equalr (a1, a2)) + call amovkr (b1, Memr[bufr], ncols) + else + call amapr (Memr[bufr], Memr[bufr], ncols, a1, a2, + b1, b2) + call achtri (Memr[bufr], Memi[buf2], ncols) + } else { + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + bufi = imgs2i (im, col1, col2, i, i) + call amaxki (Memi[bufi], nint(a1), Memi[buf2], + ncols) + call aminki (Memi[buf2], nint(a2), Memi[buf2], + ncols) + default: + bufr = imgs2r (im, col1, col2, i, i) + if (fp_equalr (a1, a2)) + call amovkr (b1, Memr[bufr], ncols) + else + call amapr (Memr[bufr], Memr[bufr], ncols, a1, + a2, b1, b2) + call achtri (Memr[bufr], Memi[buf2], ncols) + } + } + } + } + } + + # Save buffer parameters. + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end diff --git a/pkg/images/imfilter/src/fmd_hist.x b/pkg/images/imfilter/src/fmd_hist.x new file mode 100644 index 00000000..d44722d7 --- /dev/null +++ b/pkg/images/imfilter/src/fmd_hist.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FMD_ASHGMI -- Accumulate the histogram of the input vector. The output vector +# HGM (the histogram) should be cleared prior to the first call. + +procedure fmd_ashgmi (data, npix, hgm, nbins, z1, z2) + +int data[ARB] #I data vector +int npix #I number of pixels +int hgm[ARB] #U output histogram +int nbins #I number of bins in histogram +int z1, z2 #I greyscale values of first and last bins + +real dz +int bin, i + +begin + if (nbins < 2) + return + dz = real (nbins - 1) / real (z2 - z1) + + do i = 1, npix { + bin = int ((data[i] - z1) * dz) + 1 + if (bin <= 0 || bin > nbins) + next + hgm[bin] = hgm[bin] + 1 + } +end diff --git a/pkg/images/imfilter/src/fmd_maxmin.x b/pkg/images/imfilter/src/fmd_maxmin.x new file mode 100644 index 00000000..7c648a58 --- /dev/null +++ b/pkg/images/imfilter/src/fmd_maxmin.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# FMD_MAXMIN -- Find the maximum and minimum of an image allowing for +# boundary extension if necessary. + +procedure fmd_maxmin (im, xbox, ybox, boundary, constant, minimum, maximum) + +pointer im #I pointer to image +int boundary #I type of boundary extension +real constant #I constant for boundary extension +int xbox, ybox #I median filter size +real minimum #O image minimum +real maximum #O image maximum + +int i, col1, col2, line1, line2 +pointer buf +real minval, maxval + +pointer imgs2r() + +begin + if (IM_LIMTIME(im) < IM_MTIME(im) || boundary == BT_PROJECT) { + + # Set image boundary extension parameters. + call imseti (im, IM_TYBNDRY, boundary) + call imseti (im, IM_NBNDRYPIX, max (xbox / 2, ybox / 2)) + call imsetr (im, IM_BNDRYPIXVAL, constant) + + # Set the column and line boundaries. + col1 = 1 - xbox / 2 + col2 = IM_LEN(im,1) + xbox / 2 + line1 = 1 - ybox / 2 + line2 = IM_LEN(im,2) + ybox / 2 + + # Initialize the max and min values. + minimum = MAX_REAL + maximum = -MAX_REAL + + do i = line1, line2 { + buf = imgs2r (im, col1, col2, i, i) + call alimr (Memr[buf], col2 - col1 + 1, minval, maxval) + minimum = min (minimum, minval) + maximum = max (maximum, maxval) + } + + } else { + + minimum = IM_MIN(im) + maximum = IM_MAX(im) + + if (boundary == BT_CONSTANT) { + if (constant < minimum) + minimum = constant + if (constant > maximum) + maximum = constant + } + } +end diff --git a/pkg/images/imfilter/src/fmedian.h b/pkg/images/imfilter/src/fmedian.h new file mode 100644 index 00000000..2f8d13b8 --- /dev/null +++ b/pkg/images/imfilter/src/fmedian.h @@ -0,0 +1,23 @@ +# Structure definition for the FMEDIAN task + +define LEN_FMEDIAN_STRUCT 20 + +define FMED_XBOX Memi[$1] # x median filtering window +define FMED_YBOX Memi[$1+1] # y median filtering window +define FMED_MAP Memi[$1+2] # map image to histogram +define FMED_HMIN Memi[$1+3] # histogram minimum +define FMED_HMAX Memi[$1+4] # histogram maximum +define FMED_HLOW Memi[$1+5] # histogram low side rejection param +define FMED_HHIGH Memi[$1+6] # histogram high side rejection param +define FMED_NHLOW Memi[$1+7] # number of low rejected pixels +define FMED_NHHIGH Memi[$1+8] # number of high rejected pixels +define FMED_MEDIAN Memi[$1+9] # the current median +define FMED_NMEDIAN Memi[$1+10] # number less than the median +define FMED_NLTMEDIAN Memi[$1+11] # number less than the current median +define FMED_UNMAP Memi[$1+12] # rescale the quantizied values +define FMED_ZMIN Memr[P2R($1+13)] # the data minimum +define FMED_ZMAX Memr[P2R($1+14)] # the data maximum +define FMED_Z1 Memr[P2R($1+15)] # the requested data minimum +define FMED_Z2 Memr[P2R($1+16)] # the requested data maximum +define FMED_ZLOW Memr[P2R($1+17)] # data low side rejection parameter +define FMED_ZHIGH Memr[P2R($1+18)] # data high side rejection parameter diff --git a/pkg/images/imfilter/src/fmedian.x b/pkg/images/imfilter/src/fmedian.x new file mode 100644 index 00000000..0fff514b --- /dev/null +++ b/pkg/images/imfilter/src/fmedian.x @@ -0,0 +1,556 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmedian.h" + +# FMD_MEDBOX -- Median filter an image. + +procedure fmd_medbox (fmd, im1, im2, boundary, constant) + +pointer fmd #I pointer to the fmedian structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, hst +real rval +bool fp_equalr() +pointer impl2r() +errchk impl2r, fmd_buf, fmd_medboxset, fmd_medboxfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (FMED_XBOX(fmd) / 2, + FMED_YBOX(fmd)/ 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the histogram and zero. + call calloc (hst, FMED_HMAX(fmd) - FMED_HMIN(fmd) + 1, TY_INT) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + FMED_YBOX(fmd) = 1 + + # Set quantization parameters. + if (!IS_INDEFR(FMED_Z1(fmd))) + FMED_ZMIN(fmd) = FMED_Z1(fmd) + if (!IS_INDEFR(FMED_Z2(fmd))) + FMED_ZMAX(fmd) = FMED_Z2(fmd) + if (fp_equalr (real (FMED_HMIN(fmd)), FMED_ZMIN(fmd)) && + fp_equalr (real (FMED_HMAX(fmd)), FMED_ZMAX(fmd))) + FMED_MAP(fmd) = NO + else + FMED_MAP(fmd) = YES + if (IS_INDEFR(FMED_ZLOW(fmd))) { + FMED_HLOW(fmd) = FMED_HMIN(fmd) + } else { + call amapr (FMED_ZLOW(fmd), rval, 1, FMED_ZMIN(fmd), + FMED_ZMAX(fmd), real(FMED_HMIN(fmd)), real(FMED_HMAX(fmd))) + FMED_HLOW(fmd) = rval + } + if (IS_INDEFR(FMED_ZHIGH(fmd))) { + FMED_HHIGH(fmd) = FMED_HMAX(fmd) + } else { + call amapr (FMED_ZHIGH(fmd), rval, 1, FMED_ZMIN(fmd), + FMED_ZMAX(fmd), real(FMED_HMIN(fmd)), real(FMED_HMAX(fmd))) + FMED_HHIGH(fmd) = rval + } + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - FMED_XBOX(fmd) / 2 + col2 = IM_LEN(im1, 1) + FMED_XBOX(fmd) / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - FMED_YBOX(fmd) / 2 + line2 = line + FMED_YBOX(fmd) / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call fmd_buf (im1, col1, col2, line1, line2, inbuf, FMED_MAP(fmd), + FMED_ZMIN(fmd), FMED_ZMAX(fmd), real (FMED_HMIN(fmd)), + real (FMED_HMAX(fmd))) + + # Set up median filter array for each line scanned. + call fmd_medboxset (fmd, Memi[inbuf], ncols, nlines, Memi[hst], + FMED_HMAX(fmd) - FMED_HMIN(fmd) + 1, line) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Median filter the image line. + call fmd_medboxfilter (fmd, Memi[inbuf], ncols, nlines, + Memr[outbuf], int (IM_LEN(im2, 1)), Memi[hst], + FMED_HMAX(fmd) - FMED_HMIN(fmd) + 1, line) + + # Recover original data range. + if (FMED_UNMAP(fmd) == YES && FMED_MAP(fmd) == YES) + call amapr (Memr[outbuf], Memr[outbuf], int (IM_LEN(im2,1)), + real (FMED_HMIN(fmd)), real (FMED_HMAX(fmd)), + FMED_ZMIN(fmd), FMED_ZMAX(fmd)) + } + + # Free space. + call mfree (hst, TY_INT) + call mfree (inbuf, TY_INT) +end + + +# FMD_MEDBOXSET -- Set up median array for the beginning of each image line. + +procedure fmd_medboxset (fmd, data, nx, ny, hist, nbins, line) + +pointer fmd #I pointer to the fmedian structure +int data[nx, ny] #I image data buffer +int nx #I number of columns in image buffer +int ny #I number of lines in the image buffer +int hist[nbins] #U histogram +int nbins #I number of histogram bins +int line #I line number + +int i, j, xbox, ybox, hmin, hmax, hlo, hhi, nhlo, nhhi, index +int median, nmedian, nltmedian, nzero +pointer sp, filter +int amedi() + +begin + xbox = FMED_XBOX(fmd) + ybox = FMED_YBOX(fmd) + hmin = FMED_HMIN(fmd) + hmax = FMED_HMAX(fmd) + hlo = FMED_HLOW(fmd) + hhi = FMED_HHIGH(fmd) + + # Initialize. + if (line == 1) { + + call smark (sp) + call salloc (filter, xbox * ybox, TY_INT) + + # Load filter. + index = 0 + nhlo = 0 + nhhi = 0 + do j = 1, ybox { + do i = 1, xbox { + if (data[i,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,j] > hhi) { + nhhi = nhhi + 1 + next + } + Memi[filter+index] = data[i,j] + index = index + 1 + } + } + + # Load histogram. + if (index > 0) + call fmd_ashgmi (Memi[filter], index, hist, nbins, hmin, hmax) + + # Calculate the current median. + if (index > 0) + median = amedi (Memi[filter], index) + else if (nhlo < nhhi) + median = hhi + else + median = hlo + + # Calculate the number less than the current median. + nltmedian = 0 + if (index > 0) { + nltmedian = 0 + do i = 1, index { + if (Memi[filter+i-1] < median) + nltmedian = nltmedian + 1 + } + nmedian = (index - 1) / 2 + } else + nmedian = 0 + + call sfree (sp) + + } else { + + median = FMED_MEDIAN(fmd) + nltmedian = FMED_NLTMEDIAN(fmd) + nmedian = FMED_NMEDIAN(fmd) + nhlo = FMED_NHLOW(fmd) + nhhi = FMED_NHHIGH(fmd) + + # Add new points. + if (mod (line, 2) == 0) { + do i = nx - xbox + 1, nx { + if (data[i,ny] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,ny] > hhi) { + nhhi = nhhi + 1 + next + } + index = data[i, ny] - hmin + 1 + hist[index] = hist[index] + 1 + if (data[i,ny] < median) + nltmedian = nltmedian + 1 + } + } else { + do i = 1, xbox { + if (data[i,ny] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,ny] > hhi) { + nhhi = nhhi + 1 + next + } + index = data[i, ny] - hmin + 1 + hist[index] = hist[index] + 1 + if (data[i,ny] < median) + nltmedian = nltmedian + 1 + } + } + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do i = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do i = 1 , nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + + } + + # Store the results. + FMED_MEDIAN(fmd) = median + FMED_NMEDIAN(fmd) = nmedian + FMED_NLTMEDIAN(fmd) = nltmedian + FMED_NHLOW(fmd) = nhlo + FMED_NHHIGH(fmd) = nhhi +end + + +# FMD_MEDBOXFILTER -- Median filter a single image line. + +procedure fmd_medboxfilter (fmd, data, nx, ny, medline, ncols, hist, + nbins, line) + +pointer fmd #I pointer to the fmedian structure +int data[nx, ny] #I image data +int nx, ny #I dimensions of data +real medline[ncols] #O median array +int ncols #I number of output image columns +int hist[nbins] #U histogram +int nbins #I length of histogram +int line #I current line number + +begin + if (mod (line, 2) != 0) + call fmd_eforward_filter (fmd, data, nx, ny, medline, ncols, + hist, nbins) + else + call fmd_erev_filter (fmd, data, nx, ny, medline, ncols, + hist, nbins) +end + + +# FMD_EFORWARD_FILTER -- Run the median window forward. + +procedure fmd_eforward_filter (fmd, data, nx, ny, medline, ncols, hist, nbins) + +pointer fmd #I pointer to the fmedian structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram + +int i, j, xbox, ybox, dindex, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int median, nmedian, nltmedian, nzero + +begin + xbox = FMED_XBOX(fmd) + ybox = FMED_YBOX(fmd) + hmin = FMED_HMIN(fmd) + hmax = FMED_HMAX(fmd) + hlo = FMED_HLOW(fmd) + hhi = FMED_HHIGH(fmd) + + median = FMED_MEDIAN(fmd) + nmedian = FMED_NMEDIAN(fmd) + nltmedian = FMED_NLTMEDIAN(fmd) + nhlo = FMED_NHLOW(fmd) + nhhi = FMED_NHHIGH(fmd) + + # Calculate the medians for a line. + dindex = 1 + do i = 1, ncols - 1 { + + # Set median. + if ((xbox * ybox - nhlo - nhhi) > 0) + medline[i] = median + else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + + # Delete points. + do j = 1, ybox { + if (data[dindex,j] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[dindex,j] > hhi) { + nhhi = nhhi - 1 + next + } + hindex = data[dindex,j] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[dindex,j] < median) + nltmedian = nltmedian - 1 + } + + # Add points. + do j = 1, ybox { + if (data[dindex+xbox,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[dindex+xbox,j] > hhi) { + nhhi = nhhi + 1 + next + } + hindex = data[dindex+xbox,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + if (data[dindex+xbox,j] < median) + nltmedian = nltmedian + 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do j = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do j = 1, nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + + dindex = dindex + 1 + + } + + # Set the last median. + if ((xbox * ybox - nhlo - nhhi) > 0) + medline[ncols] = median + else if (nhlo < nhhi) + medline[ncols] = hhi + else + medline[ncols] = hlo + + # Delete the points from the last row. + do i = nx - xbox + 1, nx { + if (data[i,1] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[i,1] > hhi) { + nhhi = nhhi - 1 + next + } + hindex = data[i,1] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[i,1] < median) + nltmedian = nltmedian - 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + FMED_MEDIAN(fmd) = median + FMED_NMEDIAN(fmd) = nmedian + FMED_NLTMEDIAN(fmd) = nltmedian + FMED_NHLOW(fmd) = nhlo + FMED_NHHIGH(fmd) = nhhi +end + + +# FMD_EREV_FILTER -- Median filter the line in the reverse direction. + +procedure fmd_erev_filter (fmd, data, nx, ny, medline, ncols, hist, nbins) + +pointer fmd #I pointer to the fmedian structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram + +int i, j, xbox, ybox, dindex, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int median, nmedian, nltmedian, nzero + +begin + xbox = FMED_XBOX(fmd) + ybox = FMED_YBOX(fmd) + hmin = FMED_HMIN(fmd) + hmax = FMED_HMAX(fmd) + hlo = FMED_HLOW(fmd) + hhi = FMED_HHIGH(fmd) + + median = FMED_MEDIAN(fmd) + nmedian = FMED_NMEDIAN(fmd) + nltmedian = FMED_NLTMEDIAN(fmd) + nhlo = FMED_NHLOW(fmd) + nhhi = FMED_NHHIGH(fmd) + + # Calculate the medians for a line. + dindex = nx + do i = ncols, 2, -1 { + + # Set median. + if ((xbox * ybox - nhlo - nhhi) > 0) + medline[i] = median + else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + + # Delete points. + do j = 1, ybox { + if (data[dindex,j] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[dindex,j] > hhi) { + nhhi = nhhi - 1 + next + } + hindex = data[dindex,j] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[dindex,j] < median) + nltmedian = nltmedian - 1 + } + + # Add points. + do j = 1, ybox { + if (data[dindex-xbox,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[dindex-xbox,j] > hhi) { + nhhi = nhhi + 1 + next + } + hindex = data[dindex-xbox,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + if (data[dindex-xbox,j] < median) + nltmedian = nltmedian + 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do j = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do j = 1, nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + + dindex = dindex - 1 + + } + + # Set the last median. + if ((xbox * ybox - nhlo - nhhi) > 0) + medline[1] = median + else if (nhlo < nhhi) + medline[1] = hhi + else + medline[1] = hlo + + # Delete the points from the last row. + do i = 1, xbox { + if (data[i,1] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[i,1] > hhi) { + nhhi = nhhi - 1 + next + } + hindex = data[i,1] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[i,1] < median) + nltmedian = nltmedian - 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + FMED_MEDIAN(fmd) = median + FMED_NMEDIAN(fmd) = nmedian + FMED_NLTMEDIAN(fmd) = nltmedian + FMED_NHLOW(fmd) = nhlo + FMED_NHHIGH(fmd) = nhhi +end diff --git a/pkg/images/imfilter/src/fmode.h b/pkg/images/imfilter/src/fmode.h new file mode 100644 index 00000000..b276b87c --- /dev/null +++ b/pkg/images/imfilter/src/fmode.h @@ -0,0 +1,24 @@ +# Structure definition for the FMODE task + +define LEN_FMODE_STRUCT 22 + +define FMOD_XBOX Memi[$1] # x median filtering window +define FMOD_YBOX Memi[$1+1] # y median filtering window +define FMOD_MAP Memi[$1+2] # map image to histogram +define FMOD_HMIN Memi[$1+3] # histogram minimum +define FMOD_HMAX Memi[$1+4] # histogram maximum +define FMOD_HLOW Memi[$1+5] # histogram low side rejection parameter +define FMOD_HHIGH Memi[$1+6] # histogram high side rejection parameter +define FMOD_NHLOW Memi[$1+7] # number of low rejected pixels +define FMOD_NHHIGH Memi[$1+8] # number of high rejected pixels +define FMOD_MEDIAN Memi[$1+9] # the current median +define FMOD_NMEDIAN Memi[$1+10] # number less than the median +define FMOD_NLTMEDIAN Memi[$1+11] # number less than the current median +define FMOD_UNMAP Memi[$1+12] # rescale the quantizied values +define FMOD_ZMIN Memr[P2R($1+13)] # the data minimum +define FMOD_ZMAX Memr[P2R($1+14)] # the data maximum +define FMOD_Z1 Memr[P2R($1+15)] # the requested data minimum +define FMOD_Z2 Memr[P2R($1+16)] # the requested data maximum +define FMOD_ZLOW Memr[P2R($1+17)] # data low side rejection parameter +define FMOD_ZHIGH Memr[P2R($1+18)] # data high side rejection parameter +define FMOD_SUM Memr[P2R($1+19)] # running sum for mean calculation diff --git a/pkg/images/imfilter/src/fmode.x b/pkg/images/imfilter/src/fmode.x new file mode 100644 index 00000000..011c0f3a --- /dev/null +++ b/pkg/images/imfilter/src/fmode.x @@ -0,0 +1,578 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "fmode.h" + +# FMD_MODBOX -- Modal filter an image. + +procedure fmd_modbox (fmd, im1, im2, boundary, constant) + +pointer fmd #I pointer to the fmedian structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, hst +real rval +bool fp_equalr() +pointer impl2r() +errchk impl2r, fmd_buf, fmd_modboxset, fmd_modboxfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (FMOD_XBOX(fmd) / 2, + FMOD_YBOX(fmd)/ 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the histogram and zero. + call calloc (hst, FMOD_HMAX(fmd) - FMOD_HMIN(fmd) + 1, TY_INT) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + FMOD_YBOX(fmd) = 1 + + # Set quantization parameters. + if (!IS_INDEFR(FMOD_Z1(fmd))) + FMOD_ZMIN(fmd) = FMOD_Z1(fmd) + if (!IS_INDEFR(FMOD_Z2(fmd))) + FMOD_ZMAX(fmd) = FMOD_Z2(fmd) + if (fp_equalr (real (FMOD_HMIN(fmd)), FMOD_ZMIN(fmd)) && + fp_equalr (real (FMOD_HMAX(fmd)), FMOD_ZMAX(fmd))) + FMOD_MAP(fmd) = NO + else + FMOD_MAP(fmd) = YES + if (IS_INDEFR(FMOD_ZLOW(fmd))) { + FMOD_HLOW(fmd) = FMOD_HMIN(fmd) + } else { + call amapr (FMOD_ZLOW(fmd), rval, 1, FMOD_ZMIN(fmd), + FMOD_ZMAX(fmd), real(FMOD_HMIN(fmd)), real(FMOD_HMAX(fmd))) + FMOD_HLOW(fmd) = rval + } + if (IS_INDEFR(FMOD_ZHIGH(fmd))) { + FMOD_HHIGH(fmd) = FMOD_HMAX(fmd) + } else { + call amapr (FMOD_ZHIGH(fmd), rval, 1, FMOD_ZMIN(fmd), + FMOD_ZMAX(fmd), real(FMOD_HMIN(fmd)), real(FMOD_HMAX(fmd))) + FMOD_HHIGH(fmd) = rval + } + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - FMOD_XBOX(fmd) / 2 + col2 = IM_LEN(im1, 1) + FMOD_XBOX(fmd) / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - FMOD_YBOX(fmd) / 2 + line2 = line + FMOD_YBOX(fmd) / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call fmd_buf (im1, col1, col2, line1, line2, inbuf, FMOD_MAP(fmd), + FMOD_ZMIN(fmd), FMOD_ZMAX(fmd), real (FMOD_HMIN(fmd)), + real (FMOD_HMAX(fmd))) + + # Set up modal filter array for each line scanned. + call fmd_modboxset (fmd, Memi[inbuf], ncols, nlines, Memi[hst], + FMOD_HMAX(fmd) - FMOD_HMIN(fmd) + 1, line) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Modal filter the image line. + call fmd_modboxfilter (fmd, Memi[inbuf], ncols, nlines, + Memr[outbuf], int (IM_LEN(im2, 1)), Memi[hst], FMOD_HMAX(fmd) - + FMOD_HMIN(fmd) + 1, line) + + # Recover original data range. + if (FMOD_UNMAP(fmd) == YES && FMOD_MAP(fmd) == YES) + call amapr (Memr[outbuf], Memr[outbuf], int (IM_LEN(im2,1)), + real (FMOD_HMIN(fmd)), real (FMOD_HMAX(fmd)), + FMOD_ZMIN(fmd), FMOD_ZMAX(fmd)) + } + + # Free space. + call mfree (hst, TY_INT) + call mfree (inbuf, TY_INT) +end + + +# FMD_MODBOXSET -- Set up median array for the beginning of each image line. + +procedure fmd_modboxset (fmd, data, nx, ny, hist, nbins, line) + +pointer fmd #I pointer to the fmode structure +int data[nx, ny] #I image data buffer +int nx #I number of columns in image buffer +int ny #I number of lines in the image buffer +int hist[nbins] #U histogram +int nbins #I number of histogram bins +int line #I line number + +int i, j, xbox, ybox, hmin, hmax, hlo, hhi, nhlo, nhhi, index +int median, nmedian, nltmedian, nzero +pointer sp, filter +real sum +int amedi() + +begin + xbox = FMOD_XBOX(fmd) + ybox = FMOD_YBOX(fmd) + hmin = FMOD_HMIN(fmd) + hmax = FMOD_HMAX(fmd) + hlo = FMOD_HLOW(fmd) + hhi = FMOD_HHIGH(fmd) + + # Initialize. + if (line == 1) { + + call smark (sp) + call salloc (filter, xbox * ybox, TY_INT) + + # Load filter. + index = 0 + nhlo = 0 + nhhi = 0 + sum = 0.0 + do j = 1, ybox { + do i = 1, xbox { + if (data[i,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,j] > hhi) { + nhhi = nhhi + 1 + next + } + Memi[filter+index] = data[i,j] + sum = sum + data[i,j] + index = index + 1 + } + } + + # Load histogram. + if (index > 0) + call fmd_ashgmi (Memi[filter], index, hist, nbins, hmin, hmax) + + # Calculate the current median. + if (index > 0) + median = amedi (Memi[filter], index) + else if (nhlo < nhhi) + median = hhi + else + median = hlo + + # Calculate the number less than the current median. + nltmedian = 0 + if (index > 0) { + nltmedian = 0 + do i = 1, index { + if (Memi[filter+i-1] < median) + nltmedian = nltmedian + 1 + } + nmedian = (index - 1) / 2 + } else + nmedian = 0 + + call sfree (sp) + + } else { + + median = FMOD_MEDIAN(fmd) + nltmedian = FMOD_NLTMEDIAN(fmd) + nmedian = FMOD_NMEDIAN(fmd) + sum = FMOD_SUM(fmd) + nhlo = FMOD_NHLOW(fmd) + nhhi = FMOD_NHHIGH(fmd) + + # Add new points. + if (mod (line, 2) == 0) { + do i = nx - xbox + 1, nx { + if (data[i,ny] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,ny] > hhi) { + nhhi = nhhi + 1 + next + } + sum = sum + data[i,ny] + index = data[i,ny] - hmin + 1 + hist[index] = hist[index] + 1 + if (data[i,ny] < median) + nltmedian = nltmedian + 1 + } + } else { + do i = 1, xbox { + if (data[i,ny] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i,ny] > hhi) { + nhhi = nhhi + 1 + next + } + sum = sum + data[i,ny] + index = data[i,ny] - hmin + 1 + hist[index] = hist[index] + 1 + if (data[i,ny] < median) + nltmedian = nltmedian + 1 + } + } + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do i = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do i = 1 , nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + } + + # Store the results. + FMOD_MEDIAN(fmd) = median + FMOD_NMEDIAN(fmd) = nmedian + FMOD_NLTMEDIAN(fmd) = nltmedian + FMOD_NHLOW(fmd) = nhlo + FMOD_NHHIGH(fmd) = nhhi + FMOD_SUM(fmd) = sum +end + + +# FMD_MODBOXFILTER -- Median filter a single image line. + +procedure fmd_modboxfilter (fmd, data, nx, ny, medline, ncols, hist, + nbins, line) + +pointer fmd #I pointer to the fmode structure +int data[nx, ny] #I image data +int nx, ny #I dimensions of data +real medline[ncols] #O median array +int ncols #I number of output image columns +int hist[nbins] #U histogram +int nbins #I length of histogram +int line #I current line number + +begin + if (mod (line, 2) != 0) + call fmd_oforward_filter (fmd, data, nx, ny, medline, ncols, + hist, nbins) + else + call fmd_orev_filter (fmd, data, nx, ny, medline, ncols, + hist, nbins) +end + + +# FMD_OFORWARD_FILTER -- Run the median window forward. + +procedure fmd_oforward_filter (fmd, data, nx, ny, medline, ncols, hist, nbins) + +pointer fmd #I pointer to the fmode structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram + +int i, j, xbox, ybox, dindex, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int median, nmedian, nltmedian, nzero +real sum + +begin + xbox = FMOD_XBOX(fmd) + ybox = FMOD_YBOX(fmd) + hmin = FMOD_HMIN(fmd) + hmax = FMOD_HMAX(fmd) + hlo = FMOD_HLOW(fmd) + hhi = FMOD_HHIGH(fmd) + + median = FMOD_MEDIAN(fmd) + nmedian = FMOD_NMEDIAN(fmd) + nltmedian = FMOD_NLTMEDIAN(fmd) + sum = FMOD_SUM(fmd) + nhlo = FMOD_NHLOW(fmd) + nhhi = FMOD_NHHIGH(fmd) + + # Calculate the medians for a line. + dindex = 1 + do i = 1, ncols - 1 { + + # Set median. + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + medline[i] = 3.0 * median - 2.0 * sum / nzero + else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + + # Delete points. + do j = 1, ybox { + if (data[dindex,j] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[dindex,j] > hhi) { + nhhi = nhhi - 1 + next + } + sum = sum - data[dindex,j] + hindex = data[dindex,j] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[dindex,j] < median) + nltmedian = nltmedian - 1 + } + + # Add points. + do j = 1, ybox { + if (data[dindex+xbox,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[dindex+xbox,j] > hhi) { + nhhi = nhhi + 1 + next + } + sum = sum + data[dindex+xbox,j] + hindex = data[dindex+xbox,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + if (data[dindex+xbox,j] < median) + nltmedian = nltmedian + 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do j = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do j = 1, nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + + dindex = dindex + 1 + + } + + # Set the last median. + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + medline[ncols] = 3.0 * median - 2.0 * sum / nzero + else if (nhlo < nhhi) + medline[ncols] = hhi + else + medline[ncols] = hlo + + # Delete the points from the last row. + do i = nx - xbox + 1, nx { + if (data[i,1] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[i,1] > hhi) { + nhhi = nhhi - 1 + next + } + sum = sum - data[i,1] + hindex = data[i,1] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[i,1] < median) + nltmedian = nltmedian - 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + FMOD_SUM(fmd) = sum + FMOD_MEDIAN(fmd) = median + FMOD_NMEDIAN(fmd) = nmedian + FMOD_NLTMEDIAN(fmd) = nltmedian + FMOD_NHLOW(fmd) = nhlo + FMOD_NHHIGH(fmd) = nhhi +end + + +# FMD_OREV_FILTER -- Median filter the line in the reverse direction. + +procedure fmd_orev_filter (fmd, data, nx, ny, medline, ncols, hist, nbins) + +pointer fmd #I pointer to the fmode structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram + +int i, j, xbox, ybox, dindex, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int median, nmedian, nltmedian, nzero +real sum + +begin + xbox = FMOD_XBOX(fmd) + ybox = FMOD_YBOX(fmd) + hmin = FMOD_HMIN(fmd) + hmax = FMOD_HMAX(fmd) + hlo = FMOD_HLOW(fmd) + hhi = FMOD_HHIGH(fmd) + + sum = FMOD_SUM(fmd) + median = FMOD_MEDIAN(fmd) + nmedian = FMOD_NMEDIAN(fmd) + nltmedian = FMOD_NLTMEDIAN(fmd) + nhlo = FMOD_NHLOW(fmd) + nhhi = FMOD_NHHIGH(fmd) + + # Calculate the medians for a line. + dindex = nx + do i = ncols, 2, -1 { + + # Set median. + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + medline[i] = 3.0 * median - 2.0 * sum / nzero + else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + + # Delete points. + do j = 1, ybox { + if (data[dindex,j] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[dindex,j] > hhi) { + nhhi = nhhi - 1 + next + } + sum = sum - data[dindex,j] + hindex = data[dindex,j] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[dindex,j] < median) + nltmedian = nltmedian - 1 + } + + # Add points. + do j = 1, ybox { + if (data[dindex-xbox,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[dindex-xbox,j] > hhi) { + nhhi = nhhi + 1 + next + } + sum = sum + data[dindex-xbox,j] + hindex = data[dindex-xbox,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + if (data[dindex-xbox,j] < median) + nltmedian = nltmedian + 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + # Calculate the new current median. + if (nltmedian > nmedian) { + do j = 1, nbins { + median = median - 1 + nltmedian = nltmedian - hist[median-hmin+1] + if (nltmedian <= nmedian) + break + } + } else { + do j = 1, nbins { + if (nltmedian + hist[median-hmin+1] > nmedian) + break + nltmedian = nltmedian + hist[median-hmin+1] + median = median + 1 + } + } + + dindex = dindex - 1 + + } + + # Set the last median. + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + medline[1] = 3.0 * median - 2.0 * sum / nzero + else if (nhlo < nhhi) + medline[1] = hhi + else + medline[1] = hlo + + # Delete the points from the last row. + do i = 1, xbox { + if (data[i,1] < hlo) { + nhlo = nhlo - 1 + next + } + if (data[i,1] > hhi) { + nhhi = nhhi - 1 + next + } + sum = sum - data[i,1] + hindex = data[i,1] - hmin + 1 + hist[hindex] = hist[hindex] - 1 + if (data[i,1] < median) + nltmedian = nltmedian - 1 + } + + nzero = xbox * ybox - nhlo - nhhi + if (nzero > 0) + nmedian = (nzero - 1) / 2 + else + nmedian = 0 + + FMOD_SUM(fmd) = sum + FMOD_MEDIAN(fmd) = median + FMOD_NMEDIAN(fmd) = nmedian + FMOD_NLTMEDIAN(fmd) = nltmedian + FMOD_NHLOW(fmd) = nhlo + FMOD_NHHIGH(fmd) = nhhi +end diff --git a/pkg/images/imfilter/src/frmedian.h b/pkg/images/imfilter/src/frmedian.h new file mode 100644 index 00000000..4bae31aa --- /dev/null +++ b/pkg/images/imfilter/src/frmedian.h @@ -0,0 +1,17 @@ +# Structure definition for the FRMEDIAN task + +define LEN_FRMEDIAN_STRUCT 15 + +define FRMED_NRING Memi[$1] # the number of elements in the filter +define FRMED_MAP Memi[$1+1] # map image pixel to histogram scale +define FRMED_HMIN Memi[$1+2] # the minimum histogram bin +define FRMED_HMAX Memi[$1+3] # the maximum histogram bin +define FRMED_HLOW Memi[$1+4] # histogram low side rejection parameter +define FRMED_HHIGH Memi[$1+5] # histogram high side rejection parameter +define FRMED_UNMAP Memi[$1+6] # rescale the quantizied values +define FRMED_ZMIN Memr[P2R($1+7)] # the data minimum +define FRMED_ZMAX Memr[P2R($1+8)] # the data maximum +define FRMED_Z1 Memr[P2R($1+9)] # the requested data minimum +define FRMED_Z2 Memr[P2R($1+10)] # the requested data maximum +define FRMED_ZLOW Memr[P2R($1+11)] # data low side rejection parameter +define FRMED_ZHIGH Memr[P2R($1+12)] # data high side rejection parameter diff --git a/pkg/images/imfilter/src/frmedian.x b/pkg/images/imfilter/src/frmedian.x new file mode 100644 index 00000000..70f3054f --- /dev/null +++ b/pkg/images/imfilter/src/frmedian.x @@ -0,0 +1,180 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "frmedian.h" + +# FMD_MEDRING -- Median ring filter an image. + +procedure fmd_medring (fmd, im1, im2, boundary, constant, kernel, nxk, nyk) + +pointer fmd #I pointer to the frmedian structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension +short kernel[nxk,ARB] #I the ring filter kernel +int nxk, nyk #I dimensions of the kernel + + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, hst +real rval +bool fp_equalr() +pointer impl2r() +errchk impl2r, fmd_buf, fmd_remedfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2, nyk / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the histogram and zero. + call calloc (hst, FRMED_HMAX(fmd) - FRMED_HMIN(fmd) + 1, TY_INT) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + nyk = 1 + + # Set quantization parameters. + if (!IS_INDEFR(FRMED_Z1(fmd))) + FRMED_ZMIN(fmd) = FRMED_Z1(fmd) + if (!IS_INDEFR(FRMED_Z2(fmd))) + FRMED_ZMAX(fmd) = FRMED_Z2(fmd) + if (fp_equalr (real (FRMED_HMIN(fmd)), FRMED_ZMIN(fmd)) && + fp_equalr (real (FRMED_HMAX(fmd)), FRMED_ZMAX(fmd))) + FRMED_MAP(fmd) = NO + else + FRMED_MAP(fmd) = YES + if (IS_INDEFR(FRMED_ZLOW(fmd))) { + FRMED_HLOW(fmd) = FRMED_HMIN(fmd) + } else { + call amapr (FRMED_ZLOW(fmd), rval, 1, FRMED_ZMIN(fmd), + FRMED_ZMAX(fmd), real(FRMED_HMIN(fmd)), real(FRMED_HMAX(fmd))) + FRMED_HLOW(fmd) = rval + } + if (IS_INDEFR(FRMED_ZHIGH(fmd))) { + FRMED_HHIGH(fmd) = FRMED_HMAX(fmd) + } else { + call amapr (FRMED_ZHIGH(fmd), rval, 1, FRMED_ZMIN(fmd), + FRMED_ZMAX(fmd), real(FRMED_HMIN(fmd)), real(FRMED_HMAX(fmd))) + FRMED_HHIGH(fmd) = rval + } + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1, 1) + nxk / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - nyk / 2 + line2 = line + nyk / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call fmd_buf (im1, col1, col2, line1, line2, inbuf, FRMED_MAP(fmd), + FRMED_ZMIN(fmd), FRMED_ZMAX(fmd), real (FRMED_HMIN(fmd)), + real (FRMED_HMAX(fmd))) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Median filter the image line. + call fmd_remedfilter (fmd, Memi[inbuf], ncols, nlines, Memr[outbuf], + int (IM_LEN(im2, 1)), Memi[hst], FRMED_HMAX(fmd) - + FRMED_HMIN(fmd) + 1, kernel, nxk, nyk) + + # Recover original data range. + if (FRMED_UNMAP(fmd) == YES && FRMED_MAP(fmd) == YES) + call amapr (Memr[outbuf], Memr[outbuf], int (IM_LEN(im2,1)), + real (FRMED_HMIN(fmd)), real (FRMED_HMAX(fmd)), + FRMED_ZMIN(fmd), FRMED_ZMAX(fmd)) + } + + # Free space. + call mfree (hst, TY_INT) + call mfree (inbuf, TY_INT) +end + + +# FMD_REMEDFILTER -- Run the median window forward. + +procedure fmd_remedfilter (fmd, data, nx, ny, medline, ncols, hist, nbins, + kernel, xbox, ybox) + +pointer fmd #I pointer to the frmedian structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram +short kernel[xbox,ARB] #I the ring filter kernel +int xbox, ybox #I the dimensions of the kernel + +int i, j, k, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int ohmin, ohmax, nring, nmedian, nzero, hsum + +begin + nring = FRMED_NRING(fmd) + hmin = FRMED_HMIN(fmd) + hmax = FRMED_HMAX(fmd) + hlo = FRMED_HLOW(fmd) + hhi = FRMED_HHIGH(fmd) + + # Calculate the medians for a line. + do i = 1, ncols { + + # Add points. + nhlo = 0 + nhhi = 0 + ohmin = hhi + ohmax = hlo + do j = 1, ybox { + do k = 1, xbox { + if (kernel[k,j] == 0) + next + if (data[i-1+k,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i-1+k,j] > hhi) { + nhhi = nhhi + 1 + next + } + if (data[i-1+k,j] < ohmin) + ohmin = data[i-1+k,j] + if (data[i-1+k,j] > ohmax) + ohmax = data[i-1+k,j] + hindex = data[i-1+k,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + } + } + + # Compute the new median and clear the histogram. + nzero = nring - nhlo - nhhi + if (nzero > 0) { + + nmedian = (nzero - 1) / 2 + hsum = 0 + do j = ohmin - hmin + 1, ohmax - hmin + 1 { + if ((hsum + hist[j]) > nmedian) + break + hsum = hsum + hist[j] + } + medline[i] = j + hmin - 1 + call aclri (hist[ohmin-hmin+1], ohmax - ohmin + 1) + + } else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + } +end diff --git a/pkg/images/imfilter/src/frmode.h b/pkg/images/imfilter/src/frmode.h new file mode 100644 index 00000000..9f1316d3 --- /dev/null +++ b/pkg/images/imfilter/src/frmode.h @@ -0,0 +1,17 @@ +# Structure definition for the FRMODE task + +define LEN_FRMODE_STRUCT 15 + +define FRMOD_NRING Memi[$1] # the number of elements in the filter +define FRMOD_MAP Memi[$1+1] # map image to histogram +define FRMOD_HMIN Memi[$1+2] # histogram minimum +define FRMOD_HMAX Memi[$1+3] # histogram maximum +define FRMOD_HLOW Memi[$1+4] # histogram low side rejection param +define FRMOD_HHIGH Memi[$1+5] # histogram high side rejection param +define FRMOD_UNMAP Memi[$1+6] # rescale the quantizied values +define FRMOD_ZMIN Memr[P2R($1+7)] # the data minimum +define FRMOD_ZMAX Memr[P2R($1+8)] # the data maximum +define FRMOD_Z1 Memr[P2R($1+9)] # the requested data minimum +define FRMOD_Z2 Memr[P2R($1+10)] # the requested data maximum +define FRMOD_ZLOW Memr[P2R($1+11)] # data low side rejection parameter +define FRMOD_ZHIGH Memr[P2R($1+12)] # data high side rejection parameter diff --git a/pkg/images/imfilter/src/frmode.x b/pkg/images/imfilter/src/frmode.x new file mode 100644 index 00000000..faf006f8 --- /dev/null +++ b/pkg/images/imfilter/src/frmode.x @@ -0,0 +1,181 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "frmode.h" + +# FMD_MODRING -- Modal ring filter an image. + +procedure fmd_modring (fmd, im1, im2, boundary, constant, kernel, nxk, nyk) + +pointer fmd #I pointer to the frmode structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension +short kernel[nxk,ARB] #I the ring filter kernel +int nxk, nyk #I dimensions of the kernel + + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, hst +real rval +bool fp_equalr() +pointer impl2r() +errchk impl2r, fmd_buf, fmd_remedfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2, nyk / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the histogram and zero. + call calloc (hst, FRMOD_HMAX(fmd) - FRMOD_HMIN(fmd) + 1, TY_INT) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + nyk = 1 + + # Set quantization parameters. + if (!IS_INDEFR(FRMOD_Z1(fmd))) + FRMOD_ZMIN(fmd) = FRMOD_Z1(fmd) + if (!IS_INDEFR(FRMOD_Z2(fmd))) + FRMOD_ZMAX(fmd) = FRMOD_Z2(fmd) + if (fp_equalr (real (FRMOD_HMIN(fmd)), FRMOD_ZMIN(fmd)) && + fp_equalr (real (FRMOD_HMAX(fmd)), FRMOD_ZMAX(fmd))) + FRMOD_MAP(fmd) = NO + else + FRMOD_MAP(fmd) = YES + if (IS_INDEFR(FRMOD_ZLOW(fmd))) { + FRMOD_HLOW(fmd) = FRMOD_HMIN(fmd) + } else { + call amapr (FRMOD_ZLOW(fmd), rval, 1, FRMOD_ZMIN(fmd), + FRMOD_ZMAX(fmd), real(FRMOD_HMIN(fmd)), real(FRMOD_HMAX(fmd))) + FRMOD_HLOW(fmd) = rval + } + if (IS_INDEFR(FRMOD_ZHIGH(fmd))) { + FRMOD_HHIGH(fmd) = FRMOD_HMAX(fmd) + } else { + call amapr (FRMOD_ZHIGH(fmd), rval, 1, FRMOD_ZMIN(fmd), + FRMOD_ZMAX(fmd), real(FRMOD_HMIN(fmd)), real(FRMOD_HMAX(fmd))) + FRMOD_HHIGH(fmd) = rval + } + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1, 1) + nxk / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - nyk / 2 + line2 = line + nyk / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call fmd_buf (im1, col1, col2, line1, line2, inbuf, FRMOD_MAP(fmd), + FRMOD_ZMIN(fmd), FRMOD_ZMAX(fmd), real (FRMOD_HMIN(fmd)), + real (FRMOD_HMAX(fmd))) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Modal filter the image line. + call fmd_romodfilter (fmd, Memi[inbuf], ncols, nlines, Memr[outbuf], + int (IM_LEN(im2, 1)), Memi[hst], FRMOD_HMAX(fmd) - + FRMOD_HMIN(fmd) + 1, kernel, nxk, nyk) + + # Recover original data range. + if (FRMOD_UNMAP(fmd) == YES && FRMOD_MAP(fmd) == YES) + call amapr (Memr[outbuf], Memr[outbuf], int (IM_LEN(im2,1)), + real (FRMOD_HMIN(fmd)), real (FRMOD_HMAX(fmd)), + FRMOD_ZMIN(fmd), FRMOD_ZMAX(fmd)) + } + + # Free space. + call mfree (hst, TY_INT) + call mfree (inbuf, TY_INT) +end + + +# FMD_ROMODFILTER -- Run the median window forward. + +procedure fmd_romodfilter (fmd, data, nx, ny, medline, ncols, hist, nbins, + kernel, xbox, ybox) + +pointer fmd #I pointer to the frmode structure +int data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O medians +int ncols #I length of output image line +int hist[nbins] #U histogram +int nbins #I size of histogram +short kernel[xbox,ARB] #I the ring filter kernel +int xbox, ybox #I the dimensions of the kernel + +int i, j, k, hmin, hmax, hindex, hlo, hhi, nhlo, nhhi +int ohmin, ohmax, nring, nmedian, nzero, hsum +real sum + +begin + nring = FRMOD_NRING(fmd) + hmin = FRMOD_HMIN(fmd) + hmax = FRMOD_HMAX(fmd) + hlo = FRMOD_HLOW(fmd) + hhi = FRMOD_HHIGH(fmd) + + # Calculate the medians for a line. + do i = 1, ncols { + + # Add points. + nhlo = 0 + nhhi = 0 + ohmin = hhi + ohmax = hlo + sum = 0.0 + do j = 1, ybox { + do k = 1, xbox { + if (kernel[k,j] == 0) + next + if (data[i-1+k,j] < hlo) { + nhlo = nhlo + 1 + next + } + if (data[i-1+k,j] > hhi) { + nhhi = nhhi + 1 + next + } + if (data[i-1+k,j] < ohmin) + ohmin = data[i-1+k,j] + if (data[i-1+k,j] > ohmax) + ohmax = data[i-1+k,j] + hindex = data[i-1+k,j] - hmin + 1 + hist[hindex] = hist[hindex] + 1 + sum = sum + data[i-1+k,j] + } + } + + # Compute the new median and clear the histogram. + nzero = nring - nhlo - nhhi + if (nzero > 0) { + nmedian = (nzero - 1) / 2 + hsum = 0 + do j = ohmin - hmin + 1, ohmax - hmin + 1 { + if ((hsum + hist[j]) > nmedian) + break + hsum = hsum + hist[j] + } + medline[i] = 3.0 * (j + hmin - 1) - 2.0 * sum / nzero + call aclri (hist[ohmin-hmin+1], ohmax - ohmin + 1) + } else if (nhlo < nhhi) + medline[i] = hhi + else + medline[i] = hlo + } +end diff --git a/pkg/images/imfilter/src/med_buf.x b/pkg/images/imfilter/src/med_buf.x new file mode 100644 index 00000000..29d43e50 --- /dev/null +++ b/pkg/images/imfilter/src/med_buf.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MED_BUF -- Procedure to maintain a buffer of image lines. A new buffer +# is created when the buffer pointer is null or if the number of lines +# requested is changed. The minimum number of image reads is used. + +procedure med_buf (im, col1, col2, line1, line2, buf) + +pointer im #I pointer to image +int col1, col2 #I column limits in the image +int line1, line2 #I line limits in the image +pointer buf #U buffer pointer + +int i +int ncols, nlines, llast1, llast2, nllast, nclast +pointer buf1, buf2 +pointer imgs2r() +errchk imgs2r + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + # If the buffer pointer is undefined then allocate memory for the + # buffer. If the number of lines or columns changes then reallocate + # the buffer. Initialize the last line values to force a full + # buffer image read. + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + # Read in only image lines which are different from the last buffer. + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i >= llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i <= llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + # Save buffer parameters + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end diff --git a/pkg/images/imfilter/src/med_sort.x b/pkg/images/imfilter/src/med_sort.x new file mode 100644 index 00000000..70a30222 --- /dev/null +++ b/pkg/images/imfilter/src/med_sort.x @@ -0,0 +1,168 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MED_ASHSRT -- Sort a real array in increasing order using the shell sort. + +procedure med_ashsrt (a, npts) + +real a[ARB] #U array to be sorted +int npts #I number of points + +real temp +int j, k, d +define swap {temp=$1;$1=$2;$2=temp} + +begin + switch (npts) { + case 1: + ; + case 2: + if (a[1] > a[2]) + swap (a[1], a[2]) + + case 3: + if (a[1] > a[2]) + swap (a[1], a[2]) + if (a[1] > a[3]) + swap (a[1], a[3]) + if (a[2] > a[3]) + swap (a[2], a[3]) + + case 4: + if (a[1] > a[2]) + swap (a[1], a[2]) + if (a[1] > a[3]) + swap (a[1], a[3]) + if (a[1] > a[4]) + swap (a[1], a[4]) + if (a[2] > a[3]) + swap (a[2], a[3]) + if (a[2] > a[4]) + swap (a[2], a[4]) + if (a[3] > a[4]) + swap (a[3], a[4]) + + case 5: + if (a[1] > a[2]) + swap (a[1], a[2]) + if (a[1] > a[3]) + swap (a[1], a[3]) + if (a[1] > a[4]) + swap (a[1], a[4]) + if (a[1] > a[5]) + swap (a[1], a[5]) + if (a[2] > a[3]) + swap (a[2], a[3]) + if (a[2] > a[4]) + swap (a[2], a[4]) + if (a[2] > a[5]) + swap (a[2], a[5]) + if (a[3] > a[4]) + swap (a[3], a[4]) + if (a[3] > a[5]) + swap (a[3], a[5]) + if (a[4] > a[5]) + swap (a[4], a[5]) + + default: + for (d = npts; d > 1; ) { + if (d < 5) + d = 1 + else + d = (5 * d - 1) / 11 + do j = npts - d, 1, -1 { + temp = a[j] + do k = j + d, npts, d { + if (temp <= a[k]) + break + a[k-d] = a[k] + } + a[k-d] = temp + } + } + } +end + + +# MED_GSHSRT -- Procedure to sort the indices of an array using the shell +# sort. + +procedure med_gshsrt (a, index, npts) + +real a[ARB] #I array to be sorted +int index[ARB] #O array of indices +int npts #I number of points in the array + +int j, k +int d, temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + switch (npts) { + case 1: + ; + case 2: + if (a[index[1]] > a[index[2]]) + swap (index[1], index[2]) + + case 3: + if (a[index[1]] > a[index[2]]) + swap (index[1], index[2]) + if (a[index[1]] > a[index[3]]) + swap (index[1], index[3]) + if (a[index[2]] > a[index[3]]) + swap (index[2], index[3]) + + case 4: + if (a[index[1]] > a[index[2]]) + swap (index[1], index[2]) + if (a[index[1]] > a[index[3]]) + swap (index[1], index[3]) + if (a[index[1]] > a[index[4]]) + swap (index[1], index[4]) + if (a[index[2]] > a[index[3]]) + swap (index[2], index[3]) + if (a[index[2]] > a[index[4]]) + swap (index[2], index[4]) + if (a[index[3]] > a[index[4]]) + swap (index[3], index[4]) + + case 5: + if (a[index[1]] > a[index[2]]) + swap (index[1], index[2]) + if (a[index[1]] > a[index[3]]) + swap (index[1], index[3]) + if (a[index[1]] > a[index[4]]) + swap (index[1], index[4]) + if (a[index[1]] > a[index[5]]) + swap (index[1], index[5]) + if (a[index[2]] > a[index[3]]) + swap (index[2], index[3]) + if (a[index[2]] > a[index[4]]) + swap (index[2], index[4]) + if (a[index[2]] > a[index[5]]) + swap (index[2], index[5]) + if (a[index[3]] > a[index[4]]) + swap (index[3], index[4]) + if (a[index[3]] > a[index[5]]) + swap (index[3], index[5]) + if (a[index[4]] > a[index[5]]) + swap (index[4], index[5]) + + default: + for (d = npts; d > 1; ) { + if (d < 5) + d = 1 + else + d = (5 * d - 1) / 11 + do j = npts - d, 1, -1 { + temp = index[j] + do k = j + d, npts, d { + if (a[temp] <= a[index[k]]) + break + index[k-d] = index[k] + } + index[k-d] = temp + } + } + } +end diff --git a/pkg/images/imfilter/src/med_utils.x b/pkg/images/imfilter/src/med_utils.x new file mode 100644 index 00000000..5ab474f4 --- /dev/null +++ b/pkg/images/imfilter/src/med_utils.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# MED_ELL_GAUSS -- Compute the parameters of the elliptical Gaussian. + +procedure med_ell_gauss (sigma, ratio, theta, a, b, c, f, nx, ny) + +real sigma #I sigma of Gaussian in x +real ratio #I ratio of half-width in y to x +real theta #I position angle of Gaussian +real a, b, c, f #O ellipse parameters +int nx, ny #O dimensions of the kernel + +real sx2, sy2, cost, sint, discrim +bool fp_equalr () + +begin + # Define some constants. + sx2 = sigma ** 2 + sy2 = (ratio * sigma) ** 2 + cost = cos (DEGTORAD (theta)) + sint = sin (DEGTORAD (theta)) + + # Compute the ellipse parameters. + if (sigma <= 0.0) { + a = 0.0 + b = 0.0 + c = 0.0 + f = 0.0 + nx = 0 + ny = 0 + } else if (fp_equalr (ratio, 0.0)) { + + if (fp_equalr (theta, 0.0) || fp_equalr (theta, 180.)) { + a = 1. / sx2 + b = 0.0 + c = 0.0 + } else if (fp_equalr (theta, 90.0)) { + a = 0.0 + b = 0.0 + c = 1. / sx2 + } else + call error (0, "MED_GAUSS_KERNEL: Cannot make 1D Gaussian.") + + f = 0.5 + nx = 2. * sigma * abs (cost) + 1. + ny = 2. * sigma * abs (sint) + 1. + + } else { + + a = cost ** 2 / sx2 + sint ** 2 / sy2 + b = 2. * (1.0 / sx2 - 1.0 / sy2) * cost * sint + c = sint ** 2 / sx2 + cost ** 2 / sy2 + discrim = b ** 2 - 4. * a * c + f = 0.5 + nx = 2. * sqrt (-8. * c * f / discrim) + 1. + ny = 2. * sqrt (-8. * a * f / discrim) + 1. + } + + # Force the kernel to the next nearest odd integer. + if (mod (nx, 2) == 0) + nx = nx + 1 + if (mod (ny, 2) == 0) + ny = ny + 1 +end + + +# MED_RING_FILTER -- Construct the Gaussian kernel using the elliptical +# Gaussian parameters. + +int procedure med_mkring (kernel, nx, ny, a1, b1, c1, f1, a2, b2, c2, f2) + +short kernel[nx,ny] #O Gaussian kernel +int nx, ny #I dimensions of the kernel +real a1, b1, c1, f1 #I inner ellipse parameters +real a2, b2, c2, f2 #I outer ellipse parameters + +int i, j, x0, y0, x, y, nring +real k1, k2 + +begin + # Define some constants. + x0 = nx / 2 + 1 + y0 = ny / 2 + 1 + + # Compute the kernel. + nring = 0 + do j = 1, ny { + y = j - y0 + do i = 1, nx { + x = i - x0 + k1 = 0.5 * (a1 * x ** 2 + c1 * y ** 2 + b1 * x * y) + k2 = 0.5 * (a2 * x ** 2 + c2 * y ** 2 + b2 * x * y) + if (k1 >= f1 && k2 <= f2) { + kernel[i,j] = 1 + nring = nring + 1 + } else + kernel[i,j] = 0 + } + } + + return (nring) +end diff --git a/pkg/images/imfilter/src/median.h b/pkg/images/imfilter/src/median.h new file mode 100644 index 00000000..638dc966 --- /dev/null +++ b/pkg/images/imfilter/src/median.h @@ -0,0 +1,15 @@ +# Definitions file for the MEDIAN task. + +define LEN_MEDIAN_STRUCT 15 + +define MED_XBOX Memi[$1] # the x width of the filtering window +define MED_YBOX Memi[$1+1] # the y width of the filtering window +define MED_NPTS Memi[$1+2] # the number of points in window +define MED_NPTSP1 Memi[$1+3] # the number of points in window + 1 +define MED_MP Memi[$1+4] # the median pointer +define MED_START Memi[$1+5] # index of the first elememt +define MED_FINISH Memi[$1+6] # index of the last elememt +define MED_ZLOW Memr[P2R($1+7)] # the low pixel cutoff value +define MED_ZHIGH Memr[P2R($1+8)] # the high pixel cutoff value +define MED_NLOW Memi[$1+9] # the number of low side rejected pts +define MED_NHIGH Memi[$1+10] # the number of high side rejected pts diff --git a/pkg/images/imfilter/src/median.x b/pkg/images/imfilter/src/median.x new file mode 100644 index 00000000..268a6a85 --- /dev/null +++ b/pkg/images/imfilter/src/median.x @@ -0,0 +1,866 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "median.h" + +# MDE_MEDBOX -- Median filter an image using a rectangular window. + +procedure mde_medbox (mde, im1, im2, boundary, constant) + +pointer mde #I pointer to the median structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension + +int col1, col2, ncols, line, line1, line2 +pointer filter, left, right, inbuf, outbuf +pointer impl2r() +errchk impl2r, med_buf, mde_medboxset, mde_xefilter, mde_yefilter +errchk med_boxfilter + +begin + # Check for 1D images. + if (IM_NDIM(im1) == 1) + MED_YBOX(mde) = 1 + + # Set the median filtering buffers. + call calloc (filter, MED_XBOX(mde) * MED_YBOX(mde) + 1, TY_REAL) + call calloc (left, MED_XBOX(mde) * MED_YBOX(mde), TY_INT) + call calloc (right, MED_XBOX(mde) * MED_YBOX(mde), TY_INT) + + # Set the input image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (MED_XBOX(mde) / 2, + MED_YBOX(mde) / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Set the line buffer parameters. + inbuf = NULL + col1 = 1 - MED_XBOX(mde) / 2 + col2 = IM_LEN(im1, 1) + MED_XBOX(mde) / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Get ybox image lines + line1 = line - MED_YBOX(mde) / 2 + line2 = line + MED_YBOX(mde) / 2 + + # Read in the appropriate range of image lines. + call med_buf (im1, col1, col2, line1, line2, inbuf) + + # Set up median filter array for each image line. + call mde_medboxset (mde, Memr[inbuf], ncols, MED_YBOX(mde), + Memr[filter], Memi[left], Memi[right], line) + + # Get the output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Median filter the image line. + if (MED_XBOX(mde) == 1) + call mde_yefilter (mde, Memr[inbuf], ncols, MED_YBOX(mde), + Memr[filter], Memr[outbuf], int (IM_LEN(im2,1))) + else if (MED_YBOX(mde) == 1) + call mde_xefilter (mde, Memr[inbuf], ncols, MED_YBOX(mde), + Memr[outbuf], int (IM_LEN(im2,1)), Memr[filter], + Memi[left], Memi[right]) + else + call mde_medboxfilter (mde, Memr[inbuf], ncols, MED_YBOX(mde), + Memr[outbuf], int (IM_LEN(im2, 1)), Memr[filter], + Memi[left], Memi[right], line) + } + + # Free the image and filter buffers. + call mfree (inbuf, TY_REAL) + call mfree (filter, TY_REAL) + call mfree (left, TY_INT) + call mfree (right, TY_INT) +end + + +# MDE_MEDBOXSET -- Set up median array for the beginning of each image line +# The image is raster scanned so that the direction of scanning changes +# for each line. Odd numbered lines are scanned forwards and even numbered +# lines are scanned backward. If the median filters is one dimensional +# the lines are scanned forward. + +procedure mde_medboxset (mde, data, nx, ny, filter, left, right, line) + +pointer mde #I pointer to the median structure +real data[nx, ny] #I image data buffer +int nx #I number of columns in image buffer +int ny #I number of lines in the image buffer +real filter[ARB] #U array of elements to be sorted +int left[ARB] #U array of back pointers +int right[ARB] #U array of forward pointers +int line #I line number + +int i, j, k, l, xbox, ybox, nlo, nhi, npts, nptsp1, start, finish, mp +pointer sp, insert, index +real zlo, zhi + +begin + # Get algorithm parameters. + xbox = MED_XBOX(mde) + ybox = MED_YBOX(mde) + zlo = MED_ZLOW(mde) + zhi = MED_ZHIGH(mde) + + call smark (sp) + + # Initialize. + if (xbox == 1) { + + npts = 0 + nlo = 0 + nhi = 0 + + do i = 1, ybox { + if (data[1,i] < zlo) { + nlo = nlo + 1 + next + } + if (data[1,i] > zhi) { + nhi = nhi + 1 + next + } + npts = npts + 1 + filter[npts] = data[1,i] + } + if (npts > 0) + call med_ashsrt (filter, npts) + + nptsp1 = npts + 1 + mp = 1 + + } else if (line == 1 || ybox == 1) { + + npts = xbox * ybox + nptsp1 = npts + 1 + mp = 1 + + call salloc (index, npts, TY_INT) + + # Load the filter kernel. + nlo = 0 + nhi = 0 + k = 1 + do i = 1, xbox { + do j = 1, ybox { + if (data[i,j] < zlo) + nlo = nlo + 1 + if (data[i,j] > zhi) + nhi = nhi + 1 + filter[k] = data[i,j] + Memi[index+k-1] = k + k = k + 1 + } + } + + # Sort the initial filter kernel index array. + call med_gshsrt (filter, Memi[index], npts) + + # Set up the sorted linked list parameters. + start = Memi[index] + finish = Memi[index+npts-1] + left[start] = 0 + do i = 2, npts + left[Memi[index+i-1]] = Memi[index+i-2] + do i = 1, npts - 1 + right[Memi[index+i-1]] = Memi[index+i] + right[finish] = npts + 1 + + } else if (mod (line, 2) == 1) { + + npts = MED_NPTS(mde) + nptsp1 = MED_NPTSP1(mde) + mp = MED_MP(mde) + start = MED_START(mde) + finish = MED_FINISH(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + call salloc (index, xbox, TY_INT) + call salloc (insert, xbox, TY_REAL) + + # Xbox elements are deleted when lines are changed. + # These elements are always located in the first + # column of the filter kernel. + do i = 1, npts, ybox { + if (filter[i] < zlo) + nlo = nlo - 1 + if (filter[i] > zhi) + nhi = nhi - 1 + if (i == start) { + start = right[i] + left[right[i]] = 0 + } else if (i == finish) { + finish = left[i] + right[left[i]] = nptsp1 + } else { + left[right[i]] = left[i] + right[left[i]] = right[i] + } + } + + # Read in the new points. + do i = 1, xbox { + if (data[i,ny] < zlo) + nlo = nlo + 1 + if (data[i,ny] > zhi) + nhi = nhi + 1 + Memr[insert+i-1] = data[i,ny] + Memi[index+i-1] = i + } + + # Sort the new points. + call med_gshsrt (Memr[insert], Memi[index], xbox) + + # Adjust the median pointer. + mp = mp + ybox + if (mp > npts) + mp = 1 + + j = start + do i = 1, xbox { + + # Insert the new point into the filter kernel. + l = Memi[index+i-1] + k = mod (mp + (l - 1) * ybox, npts) + filter[k] = Memr[insert+l-1] + + # Find the element to the right of the inserted point. + while (j != right[finish] && Memr[insert+l-1] > filter[j]) + j = right[j] + + # Make insertions by adjusting the forward and backward links. + if (j == start) { + left[start] = k + left[k] = 0 + right[k] = start + start = k + } else if (j == right[finish]) { + right[finish] = k + left[k] = finish + right[k] = npts + 1 + finish = k + } else { + left[k] = left[j] + right[k] = right[left[j]] + right[left[j]] = k + left[j] = k + } + } + + } else { + + npts = MED_NPTS(mde) + nptsp1 = MED_NPTSP1(mde) + mp = MED_MP(mde) + start = MED_START(mde) + finish = MED_FINISH(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + call salloc (index, xbox, TY_INT) + call salloc (insert, xbox, TY_REAL) + + # Xbox elements are deleted when lines are changed. + # These elements are always located in the first + # column of the filter kernel. + do i = 1, npts, ybox { + if (filter[i] < zlo) + nlo = nlo - 1 + if (filter[i] > zhi) + nhi = nhi - 1 + if (i == start) { + start = right[i] + left[right[i]] = 0 + } else if (i == finish) { + finish = left[i] + right[left[i]] = nptsp1 + } else { + left[right[i]] = left[i] + right[left[i]] = right[i] + } + } + + # Find points to be inserted. + j = nx - xbox + 1 + do i = 1, xbox { + if (data[j,ny] < zlo) + nlo = nlo + 1 + if (data[j,ny] > zhi) + nhi = nhi + 1 + Memr[insert+i-1] = data[j,ny] + Memi[index+i-1] = i + j = j + 1 + } + + # Sort the new points. + call med_gshsrt (Memr[insert], Memi[index], xbox) + + # Do a merge sort of the old and new points. + j = start + do i = 1, xbox { + + # Insert the new point into the filter kernel + l = Memi[index+i-1] + k = mod (mp + (l - 1) * ybox, npts) + filter[k] = Memr[insert+l-1] + + # Find the element to the right of the inserted point + while (j != right[finish] && Memr[insert+l-1] > filter[j]) + j = right[j] + + # Make insertions by adjusting the forward and backward links + if (j == start) { + left[start] = k + left[k] = 0 + right[k] = start + start = k + } else if (j == right[finish]) { + right[finish] = k + left[k] = finish + right[k] = npts + 1 + finish = k + } else { + left[k] = left[j] + right[k] = right[left[j]] + right[left[j]] = k + left[j] = k + } + } + + # Adjust the filter kernel pointer for backscanned lines + mp = mp - ybox + if (mp < 1) + mp = npts + mp + } + + MED_NPTS(mde) = npts + MED_NPTSP1(mde) = nptsp1 + MED_MP(mde) = mp + MED_START(mde) = start + MED_FINISH(mde) = finish + MED_NLOW(mde) = nlo + MED_NHIGH(mde) = nhi + + call sfree (sp) +end + + +# MDE_MEDBOXFILTER -- Median filter a single image line. + +procedure mde_medboxfilter (mde, data, nx, ny, median, ncols, filter, left, + right, line) + +pointer mde #I pointer to the median structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real median[ncols] #O median array +int ncols #I number of output image columns +real filter[ARB] #U the median array of points to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers +int line #I current line number + +begin + if (mod (line, 2) == 0) + call mde_ereverse_boxfilter (mde, data, nx, ny, median, ncols, + filter, left, right) + else + call mde_eforward_boxfilter (mde, data, nx, ny, median, ncols, + filter, left, right) +end + + +# MDE_EFORWARD_BOXFILTER -- Median filter a single image line + +procedure mde_eforward_boxfilter (mde, data, nx, ny, median, ncols, + filter, left, right) + +pointer mde #I pointer to the median filtering structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real median[ncols] #O median array +int ncols #I number of output image columns +real filter[ARB] #U the array of points to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, l, col, nzero, nhalf, xbox, ybox, npts, nptsp1 +int nlo, nhi, start, finish, mp +real zlo, zhi +pointer sp, index + + +begin + xbox = MED_XBOX(mde) + ybox = MED_YBOX(mde) + zlo = MED_ZLOW(mde) + zhi = MED_ZHIGH(mde) + npts = MED_NPTS(mde) + nptsp1 = MED_NPTSP1(mde) + + start = MED_START(mde) + finish = MED_FINISH(mde) + mp = MED_MP(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + call smark (sp) + call salloc (index, ybox, TY_INT) + + col = 1 + xbox + do i = 1, ncols - 1 { + + # Calculate the median + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[i] = filter[k] + else if (nlo < nhi) + median[i] = zhi + else + median[i] = zlo + + # Delete points. + do j = mp, mp + ybox - 1 { + + if (filter[j] < zlo) + nlo = nlo - 1 + if (filter[j] > zhi) + nhi = nhi - 1 + + if (j == start) { + start = right[j] + left[right[j]] = 0 + } else if (j == finish) { + finish = left[j] + right[left[j]] = nptsp1 + } else { + right[left[j]] = right[j] + left[right[j]] = left[j] + } + + } + + # Update the median kernel. + do j = 1, ybox { + if (data[col,j] < zlo) + nlo = nlo + 1 + if (data[col,j] > zhi) + nhi = nhi + 1 + filter[mp+j-1] = data[col,j] + Memi[index+j-1] = j + } + + # Sort array to be inserted. + call med_gshsrt (filter[mp], Memi[index], ybox) + + # Merge the sorted lists. + k = start + do j = 1, ybox { + + # Position in filter kernel of new point + l = Memi[index+j-1] + mp - 1 + + # Find the element to the right of the point to be inserted + while (filter[l] > filter[k] && k != right[finish]) + k = right[k] + + # Update the linked list + if (k == start) { + left[start] = l + left[l] = 0 + right[l] = start + start = l + } else if (k == right[finish]) { + right[finish] = l + left[l] = finish + right[l] = nptsp1 + finish = l + } else { + left[l] = left[k] + right[l] = right[left[k]] + right[left[k]] = l + left[k] = l + } + + } + + # Increment the median pointer. + mp = mp + ybox + if (mp > npts) + mp = 1 + + col = col + 1 + } + + # Calculate the last median. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[ncols] = filter[k] + else if (nlo < nhi) + median[ncols] = zhi + else + median[ncols] = zlo + + MED_START(mde) = start + MED_FINISH(mde) = finish + MED_MP(mde) = mp + MED_NLOW(mde) = nlo + MED_NHIGH(mde) = nhi + + call sfree (sp) +end + + +# MDE_EREV_BOXFILTER -- Median filter a single image line in reverse + +procedure mde_ereverse_boxfilter (mde, data, nx, ny, median, ncols, + filter, left, right) + +pointer mde #I pointer to the median fitting structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real median[ncols] #O median array +int ncols #I number of output image columns +real filter[ARB] #U the array of data to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, l, col, nhalf, xbox, ybox, npts, start, finish, nlo, nhi, mp +int nptsp1, nzero +pointer sp, index +real zlo, zhi + +begin + xbox = MED_XBOX(mde) + ybox = MED_YBOX(mde) + npts = MED_NPTS(mde) + nptsp1 = MED_NPTSP1(mde) + zlo = MED_ZLOW(mde) + zhi = MED_ZHIGH(mde) + + start = MED_START(mde) + finish = MED_FINISH(mde) + mp = MED_MP(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + call smark (sp) + call salloc (index, ybox, TY_INT) + + col = nx - xbox + do i = ncols, 2, - 1 { + + # Calculate the median. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[i] = filter[k] + else if (nlo < nhi) + median[i] = zhi + else + median[i] = zlo + + # Delete points. + do j = mp, mp + ybox - 1 { + + if (filter[j] < zlo) + nlo = nlo - 1 + if (filter[j] > zhi) + nhi = nhi - 1 + if (j == start) { + start = right[j] + left[right[j]] = 0 + } else if (j == finish) { + finish = left[j] + right[left[j]] = nptsp1 + } else { + right[left[j]] = right[j] + left[right[j]] = left[j] + } + + } + + # Update the median kernel. + do j = 1, ybox { + if (data[col,j] < zlo) + nlo = nlo + 1 + if (data[col,j] > zhi) + nhi = nhi + 1 + filter[mp+j-1] = data[col,j] + Memi[index+j-1] = j + } + + # Sort array to be inserted. + call med_gshsrt (filter[mp], Memi[index], ybox) + + # Merge the sorted lists. + k = start + do j = 1, ybox { + + # Find position in filter kernel of new point. + l = Memi[index+j-1] + mp - 1 + + # Find the element to the right of the point to be inserted. + while (filter[l] > filter[k] && k != right[finish]) + k = right[k] + + # Update the linked list. + if (k == start) { + left[start] = l + left[l] = 0 + right[l] = start + start = l + } else if (k == right[finish]) { + right[finish] = l + left[l] = finish + right[l] = nptsp1 + finish = l + } else { + left[l] = left[k] + right[l] = right[left[k]] + right[left[k]] = l + left[k] = l + } + + } + + # Increment the median pointer. + mp = mp - ybox + if (mp < 1) + mp = mp + npts + + col = col - 1 + } + + # Calculate the last median. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[1] = filter[k] + else if (nlo < nhi) + median[1] = zhi + else + median[1] = zlo + + MED_START(mde) = start + MED_FINISH(mde) = finish + MED_MP(mde) = mp + MED_NLOW(mde) = nlo + MED_NHIGH(mde) = nhi + + call sfree (sp) +end + + +# MDE_XEFILTER -- Median filter a single image line in the x direction. +# The filter always moves from left to right. + +procedure mde_xefilter (mde, data, nx, ny, median, ncols, filter, left, right) + +pointer mde #I pointer to the median structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real median[ncols] #O median array +int ncols #I number of output image columns +real filter[ARB] #U the array of points to be medianed +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, start, finish, mp, xbox, npts, nptsp1, nhalf, nlo, nhi, nzero +real zlo, zhi + +begin + xbox = MED_XBOX(mde) + npts = MED_NPTS(mde) + nptsp1 = MED_NPTSP1(mde) + zlo = MED_ZLOW(mde) + zhi = MED_ZHIGH(mde) + + start = MED_START(mde) + finish = MED_FINISH(mde) + mp = MED_MP(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + # Median filter an image line. + do i = 1, ncols - 1 { + + # Calculate the median. + k = start + nzero = npts - nhi - nlo + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[i] = filter[k] + else if (nlo < nhi) + median[i] = zhi + else + median[i] = zlo + + # Delete points from the filter kernel. + if (filter[mp] < zlo) + nlo = nlo - 1 + if (filter[mp] > zhi) + nhi = nhi - 1 + + if (mp == start) { + start = right[mp] + left[right[mp]] = 0 + } else + right[left[mp]] = right[mp] + + if (mp == finish) { + finish = left[mp] + right[left[mp]] = nptsp1 + } else + left[right[mp]] = left[mp] + + # Update the median kernel. + if (data[i+xbox,1] < zlo) + nlo = nlo + 1 + if (data[i+xbox,1] > zhi) + nhi = nhi + 1 + filter[mp] = data[i+xbox,1] + + # Find the point to the right of the point to be inserted. + k = start + while (k != right[finish] && filter[mp] > filter[k]) + k = right[k] + + # Insert points into the filter kernel. + if (k == start) { + left[start] = mp + left[mp] = 0 + right[mp] = start + start = mp + } else if (k == right[finish]) { + right[finish] = mp + left[mp] = finish + right[mp] = nptsp1 + finish = mp + } else { + left[mp] = left[k] + right[mp] = right[left[k]] + right[left[k]] = mp + left[k] = mp + } + + # Increment median counter + mp = mp + 1 + if (mp > npts) + mp = 1 + } + + # Calculate the last median + nzero = npts - nhi - nlo + nhalf = (nzero - 1) / 2 + k = start + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + median[ncols] = filter[k] + else if (nlo < nhi) + median[ncols] = zhi + else + median[ncols] = zlo + + MED_START(mde) = start + MED_FINISH(mde) = finish + MED_MP(mde) = mp + MED_NLOW(mde) = nlo + MED_NHIGH(mde) = nhi +end + + +# MDE_YEFILTER -- Median filter a single image line in the y direction + +procedure mde_yefilter (mde, data, nx, ny, filter, median, ncols) + +pointer mde #I pointer to the median structure +real data[nx,ny] #I image data +int nx, ny #I dimensions of data +real filter[ARB] #U array containing the points to be medianed +real median[ncols] #O median array +int ncols #I number of output image columns + +int i, j, npts, nlo, nhi +real zlo, zhi + +begin + zlo = MED_ZLOW(mde) + zhi = MED_ZHIGH(mde) + + npts = MED_NPTS(mde) + nlo = MED_NLOW(mde) + nhi = MED_NHIGH(mde) + + do i = 1, ncols - 1 { + + # Calculate the new median. + if (npts > 0) + median[i] = filter[(npts+1)/2] + else if (nlo < nhi) + median[i] = zhi + else + median[i] = zlo + + # Update the median kernel. + npts = 0 + nlo = 0 + nhi = 0 + do j = 1, ny { + if (data[i+1,j] < zlo) { + nlo = nlo + 1 + next + } + if (data[i+1,j] > zhi) { + nhi = nhi + 1 + next + } + npts = npts + 1 + filter[npts] = data[i+1,j] + } + + if (npts > 0) + call med_ashsrt (filter, npts) + + } + + # Calculate the last median + if (npts > 0) + median[ncols] = filter[(npts+1)/2] + else if (nlo < nhi) + median[ncols] = zhi + else + median[ncols] = zlo + + # Store the results. + MED_NPTS(mde) = npts + MED_NLOW(mde) = nlo + MED_NHIGH(mde) = nhi +end diff --git a/pkg/images/imfilter/src/mkpkg b/pkg/images/imfilter/src/mkpkg new file mode 100644 index 00000000..4da107d5 --- /dev/null +++ b/pkg/images/imfilter/src/mkpkg @@ -0,0 +1,43 @@ +# Library for the IMAGES IMFILTER Subpackage Tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + aboxcar.x + boxcar.x + convolve.x + fmd_buf.x + fmd_hist.x + fmd_maxmin.x + fmedian.x fmedian.h + fmode.x fmode.h + frmedian.x frmedian.h + frmode.x frmode.h + med_buf.x + median.x median.h + med_sort.x + med_utils.x + mode.x mode.h + radcnv.x + rmedian.x rmedian.h + rmode.x rmode.h + runmed.x + t_boxcar.x + t_convolve.x + t_fmedian.x fmedian.h + t_fmode.x fmode.h + t_frmedian.x frmedian.h + t_frmode.x frmode.h + t_gauss.x + t_gradient.x + t_laplace.x + t_median.x median.h + t_mode.x mode.h + t_rmedian.x rmedian.h + t_rmode.x rmode.h + t_runmed.x + xyconvolve.x + ; diff --git a/pkg/images/imfilter/src/mode.h b/pkg/images/imfilter/src/mode.h new file mode 100644 index 00000000..13155dd1 --- /dev/null +++ b/pkg/images/imfilter/src/mode.h @@ -0,0 +1,16 @@ +# Definitions file for the MODE task. + +define LEN_MODE_STRUCT 15 + +define MOD_XBOX Memi[$1] # the x width of the filtering window +define MOD_YBOX Memi[$1+1] # the y width of the filtering window +define MOD_NPTS Memi[$1+2] # the number of points in window +define MOD_NPTSP1 Memi[$1+3] # the number of points in window + 1 +define MOD_MP Memi[$1+4] # the median pointer +define MOD_START Memi[$1+5] # index of the first elememt +define MOD_FINISH Memi[$1+6] # index of the last elememt +define MOD_ZLOW Memr[P2R($1+7)] # the low pixel cutoff value +define MOD_ZHIGH Memr[P2R($1+8)] # the high pixel cutoff value +define MOD_NLOW Memi[$1+9] # the number of low side rejected pts +define MOD_NHIGH Memi[$1+10] # the number of high side rejected pts +define MOD_SUM Memr[P2R($1+11)] # running sum used for computing mean diff --git a/pkg/images/imfilter/src/mode.x b/pkg/images/imfilter/src/mode.x new file mode 100644 index 00000000..29c95e27 --- /dev/null +++ b/pkg/images/imfilter/src/mode.x @@ -0,0 +1,903 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mode.h" + +# MDE_MODBOX -- Modal filter an image using a rectangular window. + +procedure mde_modbox (mde, im1, im2, boundary, constant) + +pointer mde #I pointer to the mode structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension + +int col1, col2, ncols, line, line1, line2 +pointer filter, left, right, inbuf, outbuf +pointer impl2r() +errchk impl2r, med_buf, mde_medboxset, med_xefilter, mde_yefilter +errchk med_boxfilter + +begin + # Check for 1D images. + if (IM_NDIM(im1) == 1) + MOD_YBOX(mde) = 1 + + # Set the mode filtering buffers. + call calloc (filter, MOD_XBOX(mde) * MOD_YBOX(mde) + 1, TY_REAL) + call calloc (left, MOD_XBOX(mde) * MOD_YBOX(mde), TY_INT) + call calloc (right, MOD_XBOX(mde) * MOD_YBOX(mde), TY_INT) + + # Set the input image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (MOD_XBOX(mde) / 2, + MOD_YBOX(mde) / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Set the line buffer parameters. + inbuf = NULL + col1 = 1 - MOD_XBOX(mde) / 2 + col2 = IM_LEN(im1, 1) + MOD_XBOX(mde) / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Get ybox image lines + line1 = line - MOD_YBOX(mde) / 2 + line2 = line + MOD_YBOX(mde) / 2 + + # Read in the appropriate range of image lines. + call med_buf (im1, col1, col2, line1, line2, inbuf) + + # Set up modal filter array for each image line. + call mde_modboxset (mde, Memr[inbuf], ncols, MOD_YBOX(mde), + Memr[filter], Memi[left], Memi[right], line) + + # Get the output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Modal filter the image line. + if (MOD_XBOX(mde) == 1) + call mde_yofilter (mde, Memr[inbuf], ncols, MOD_YBOX(mde), + Memr[filter], Memr[outbuf], int (IM_LEN(im2,1))) + else if (MOD_YBOX(mde) == 1) + call mde_xofilter (mde, Memr[inbuf], ncols, MOD_YBOX(mde), + Memr[outbuf], int (IM_LEN(im2,1)), Memr[filter], + Memi[left], Memi[right]) + else + call mde_modboxfilter (mde, Memr[inbuf], ncols, MOD_YBOX(mde), + Memr[outbuf], int (IM_LEN(im2, 1)), Memr[filter], + Memi[left], Memi[right], line) + } + + # Free the image and filter buffers. + call mfree (inbuf, TY_REAL) + call mfree (filter, TY_REAL) + call mfree (left, TY_INT) + call mfree (right, TY_INT) +end + + +# MDE_MODBOXSET -- Set up mode array for the beginning of each image line +# The image is raster scanned so that the direction of scanning changes +# for each line. Odd numbered lines are scanned forwards and even numbered +# lines are scanned backward. If the mode filters is one dimensional +# the lines are scanned forward. + +procedure mde_modboxset (mde, data, nx, ny, filter, left, right, line) + +pointer mde #I pointer to the mode structure +real data[nx, ny] #I image data buffer +int nx #I number of columns in image buffer +int ny #I number of lines in the image buffer +real filter[ARB] #U array of elements to be sorted +int left[ARB] #U array of back pointers +int right[ARB] #U array of forward pointers +int line #I line number + +int i, j, k, l, xbox, ybox, nlo, nhi, npts, nptsp1, start, finish, mp +pointer sp, insert, index +real sum, zlo, zhi + +begin + # Get algorithm parameters. + xbox = MOD_XBOX(mde) + ybox = MOD_YBOX(mde) + zlo = MOD_ZLOW(mde) + zhi = MOD_ZHIGH(mde) + + call smark (sp) + + # Initialize. + if (xbox == 1) { + + npts = 0 + nlo = 0 + nhi = 0 + sum = 0.0 + + do i = 1, ybox { + if (data[1,i] < zlo) { + nlo = nlo + 1 + next + } + if (data[1,i] > zhi) { + nhi = nhi + 1 + next + } + npts = npts + 1 + sum = sum + data[1,i] + filter[npts] = data[1,i] + } + if (npts > 0) + call med_ashsrt (filter, npts) + + nptsp1 = npts + 1 + mp = 1 + + } else if (line == 1 || ybox == 1) { + + npts = xbox * ybox + nptsp1 = npts + 1 + mp = 1 + + call salloc (index, npts, TY_INT) + + # Load the filter kernel. + nlo = 0 + nhi = 0 + sum = 0.0 + k = 1 + do i = 1, xbox { + do j = 1, ybox { + if (data[i,j] < zlo) + nlo = nlo + 1 + else if (data[i,j] > zhi) + nhi = nhi + 1 + else + sum = sum + data[i,j] + filter[k] = data[i,j] + Memi[index+k-1] = k + k = k + 1 + } + } + + # Sort the initial filter kernel index array. + call med_gshsrt (filter, Memi[index], npts) + + # Set up the sorted linked list parameters. + start = Memi[index] + finish = Memi[index+npts-1] + left[start] = 0 + do i = 2, npts + left[Memi[index+i-1]] = Memi[index+i-2] + do i = 1, npts - 1 + right[Memi[index+i-1]] = Memi[index+i] + right[finish] = npts + 1 + + } else if (mod (line, 2) == 1) { + + npts = MOD_NPTS(mde) + nptsp1 = MOD_NPTSP1(mde) + mp = MOD_MP(mde) + start = MOD_START(mde) + finish = MOD_FINISH(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + call salloc (index, xbox, TY_INT) + call salloc (insert, xbox, TY_REAL) + + # Xbox elements are deleted when lines are changed. + # These elements are always located in the first + # column of the filter kernel. + do i = 1, npts, ybox { + if (filter[i] < zlo) + nlo = nlo - 1 + else if (filter[i] > zhi) + nhi = nhi - 1 + else + sum = sum - filter[i] + if (i == start) { + start = right[i] + left[right[i]] = 0 + } else if (i == finish) { + finish = left[i] + right[left[i]] = nptsp1 + } else { + left[right[i]] = left[i] + right[left[i]] = right[i] + } + } + + # Read in the new points. + do i = 1, xbox { + if (data[i,ny] < zlo) + nlo = nlo + 1 + else if (data[i,ny] > zhi) + nhi = nhi + 1 + else + sum = sum + data[i,ny] + Memr[insert+i-1] = data[i,ny] + Memi[index+i-1] = i + } + + # Sort the new points. + call med_gshsrt (Memr[insert], Memi[index], xbox) + + # Adjust the mode pointer. + mp = mp + ybox + if (mp > npts) + mp = 1 + + j = start + do i = 1, xbox { + + # Insert the new point into the filter kernel. + l = Memi[index+i-1] + k = mod (mp + (l - 1) * ybox, npts) + filter[k] = Memr[insert+l-1] + + # Find the element to the right of the inserted point. + while (j != right[finish] && Memr[insert+l-1] > filter[j]) + j = right[j] + + # Make insertions by adjusting the forward and backward links. + if (j == start) { + left[start] = k + left[k] = 0 + right[k] = start + start = k + } else if (j == right[finish]) { + right[finish] = k + left[k] = finish + right[k] = npts + 1 + finish = k + } else { + left[k] = left[j] + right[k] = right[left[j]] + right[left[j]] = k + left[j] = k + } + } + + } else { + + npts = MOD_NPTS(mde) + nptsp1 = MOD_NPTSP1(mde) + mp = MOD_MP(mde) + start = MOD_START(mde) + finish = MOD_FINISH(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + call salloc (index, xbox, TY_INT) + call salloc (insert, xbox, TY_REAL) + + # Xbox elements are deleted when lines are changed. + # These elements are always located in the first + # column of the filter kernel. + do i = 1, npts, ybox { + if (filter[i] < zlo) + nlo = nlo - 1 + else if (filter[i] > zhi) + nhi = nhi - 1 + else + sum = sum - filter[i] + if (i == start) { + start = right[i] + left[right[i]] = 0 + } else if (i == finish) { + finish = left[i] + right[left[i]] = nptsp1 + } else { + left[right[i]] = left[i] + right[left[i]] = right[i] + } + } + + # Find points to be inserted. + j = nx - xbox + 1 + do i = 1, xbox { + if (data[j,ny] < zlo) + nlo = nlo + 1 + else if (data[j,ny] > zhi) + nhi = nhi + 1 + else + sum = sum + data[j,ny] + Memr[insert+i-1] = data[j,ny] + Memi[index+i-1] = i + j = j + 1 + } + + # Sort the new points. + call med_gshsrt (Memr[insert], Memi[index], xbox) + + # Do a merge sort of the old and new points. + j = start + do i = 1, xbox { + + # Insert the new point into the filter kernel + l = Memi[index+i-1] + k = mod (mp + (l - 1) * ybox, npts) + filter[k] = Memr[insert+l-1] + + # Find the element to the right of the inserted point + while (j != right[finish] && Memr[insert+l-1] > filter[j]) + j = right[j] + + # Make insertions by adjusting the forward and backward links + if (j == start) { + left[start] = k + left[k] = 0 + right[k] = start + start = k + } else if (j == right[finish]) { + right[finish] = k + left[k] = finish + right[k] = npts + 1 + finish = k + } else { + left[k] = left[j] + right[k] = right[left[j]] + right[left[j]] = k + left[j] = k + } + } + + # Adjust the filter kernel pointer for backscanned lines + mp = mp - ybox + if (mp < 1) + mp = npts + mp + } + + MOD_NPTS(mde) = npts + MOD_NPTSP1(mde) = nptsp1 + MOD_MP(mde) = mp + MOD_START(mde) = start + MOD_FINISH(mde) = finish + MOD_NLOW(mde) = nlo + MOD_NHIGH(mde) = nhi + MOD_SUM(mde) = sum + + call sfree (sp) +end + + +# MDE_MODBOXFILTER -- Modal filter a single image line. + +procedure mde_modboxfilter (mde, data, nx, ny, mode, ncols, filter, left, + right, line) + +pointer mde #I pointer to the mode structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real mode[ncols] #O mode array +int ncols #I number of output image columns +real filter[ARB] #U the mode array of points to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers +int line #I current line number + +begin + if (mod (line, 2) == 0) + call mde_oreverse_boxfilter (mde, data, nx, ny, mode, ncols, + filter, left, right) + else + call mde_oforward_boxfilter (mde, data, nx, ny, mode, ncols, + filter, left, right) +end + + +# MDE_OFORWARD_BOXFILTER -- Median filter a single image line + +procedure mde_oforward_boxfilter (mde, data, nx, ny, mode, ncols, + filter, left, right) + +pointer mde #I pointer to the mode filtering structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real mode[ncols] #O mode array +int ncols #I number of output image columns +real filter[ARB] #U the array of points to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, l, col, nzero, nhalf, xbox, ybox, npts, nptsp1 +int nlo, nhi, start, finish, mp +real sum, zlo, zhi +pointer sp, index + +begin + xbox = MOD_XBOX(mde) + ybox = MOD_YBOX(mde) + zlo = MOD_ZLOW(mde) + zhi = MOD_ZHIGH(mde) + npts = MOD_NPTS(mde) + nptsp1 = MOD_NPTSP1(mde) + + start = MOD_START(mde) + finish = MOD_FINISH(mde) + mp = MOD_MP(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + call smark (sp) + call salloc (index, ybox, TY_INT) + + col = 1 + xbox + do i = 1, ncols - 1 { + + # Calculate the mode. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[i] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[i] = zhi + else + mode[i] = zlo + + # Delete points. + do j = mp, mp + ybox - 1 { + + if (filter[j] < zlo) + nlo = nlo - 1 + else if (filter[j] > zhi) + nhi = nhi - 1 + else + sum = sum - filter[j] + + if (j == start) { + start = right[j] + left[right[j]] = 0 + } else if (j == finish) { + finish = left[j] + right[left[j]] = nptsp1 + } else { + right[left[j]] = right[j] + left[right[j]] = left[j] + } + + } + + # Update the mode kernel. + do j = 1, ybox { + if (data[col,j] < zlo) + nlo = nlo + 1 + else if (data[col,j] > zhi) + nhi = nhi + 1 + else + sum = sum + data[col,j] + filter[mp+j-1] = data[col,j] + Memi[index+j-1] = j + } + + # Sort array to be inserted. + call med_gshsrt (filter[mp], Memi[index], ybox) + + # Merge the sorted lists. + k = start + do j = 1, ybox { + + # Position in filter kernel of new point + l = Memi[index+j-1] + mp - 1 + + # Find the element to the right of the point to be inserted + while (filter[l] > filter[k] && k != right[finish]) + k = right[k] + + # Update the linked list + if (k == start) { + left[start] = l + left[l] = 0 + right[l] = start + start = l + } else if (k == right[finish]) { + right[finish] = l + left[l] = finish + right[l] = nptsp1 + finish = l + } else { + left[l] = left[k] + right[l] = right[left[k]] + right[left[k]] = l + left[k] = l + } + + } + + # Increment the mode pointer. + mp = mp + ybox + if (mp > npts) + mp = 1 + + col = col + 1 + } + + # Calculate the last mode. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[ncols] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[ncols] = zhi + else + mode[ncols] = zlo + + MOD_START(mde) = start + MOD_FINISH(mde) = finish + MOD_MP(mde) = mp + MOD_NLOW(mde) = nlo + MOD_NHIGH(mde) = nhi + MOD_SUM(mde) = sum + + call sfree (sp) +end + + +# MDE_OREV_BOXFILTER -- Median filter a single image line in reverse + +procedure mde_oreverse_boxfilter (mde, data, nx, ny, mode, ncols, + filter, left, right) + +pointer mde #I pointer to the mode fitting structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real mode[ncols] #O mode array +int ncols #I number of output image columns +real filter[ARB] #U the array of data to be filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, l, col, nhalf, xbox, ybox, npts, start, finish, nlo, nhi, mp +int nptsp1, nzero +pointer sp, index +real sum, zlo, zhi + +begin + xbox = MOD_XBOX(mde) + ybox = MOD_YBOX(mde) + npts = MOD_NPTS(mde) + nptsp1 = MOD_NPTSP1(mde) + zlo = MOD_ZLOW(mde) + zhi = MOD_ZHIGH(mde) + + start = MOD_START(mde) + finish = MOD_FINISH(mde) + mp = MOD_MP(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + call smark (sp) + call salloc (index, ybox, TY_INT) + + col = nx - xbox + do i = ncols, 2, - 1 { + + # Calculate the mode. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[i] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[i] = zhi + else + mode[i] = zlo + + # Delete points. + do j = mp, mp + ybox - 1 { + + if (filter[j] < zlo) + nlo = nlo - 1 + else if (filter[j] > zhi) + nhi = nhi - 1 + else + sum = sum - filter[j] + if (j == start) { + start = right[j] + left[right[j]] = 0 + } else if (j == finish) { + finish = left[j] + right[left[j]] = nptsp1 + } else { + right[left[j]] = right[j] + left[right[j]] = left[j] + } + + } + + # Update the mode kernel. + do j = 1, ybox { + if (data[col,j] < zlo) + nlo = nlo + 1 + else if (data[col,j] > zhi) + nhi = nhi + 1 + else + sum = sum + data[col,j] + filter[mp+j-1] = data[col,j] + Memi[index+j-1] = j + } + + # Sort array to be inserted. + call med_gshsrt (filter[mp], Memi[index], ybox) + + # Merge the sorted lists. + k = start + do j = 1, ybox { + + # Find position in filter kernel of new point. + l = Memi[index+j-1] + mp - 1 + + # Find the element to the right of the point to be inserted. + while (filter[l] > filter[k] && k != right[finish]) + k = right[k] + + # Update the linked list. + if (k == start) { + left[start] = l + left[l] = 0 + right[l] = start + start = l + } else if (k == right[finish]) { + right[finish] = l + left[l] = finish + right[l] = nptsp1 + finish = l + } else { + left[l] = left[k] + right[l] = right[left[k]] + right[left[k]] = l + left[k] = l + } + + } + + # Increment the mode pointer. + mp = mp - ybox + if (mp < 1) + mp = mp + npts + + col = col - 1 + } + + # Calculate the last mode. + k = start + nzero = npts - nlo - nhi + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[1] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[1] = zhi + else + mode[1] = zlo + + MOD_START(mde) = start + MOD_FINISH(mde) = finish + MOD_MP(mde) = mp + MOD_NLOW(mde) = nlo + MOD_NHIGH(mde) = nhi + MOD_SUM(mde) = sum + + call sfree (sp) +end + + +# MDE_XOFILTER -- Modal filter a single image line in the x direction. +# The filter always moves from left to right. + +procedure mde_xofilter (mde, data, nx, ny, mode, ncols, filter, left, right) + +pointer mde #I pointer to the mode structure +real data[nx, ny] #I image data +int nx, ny #I dimensions of data +real mode[ncols] #O mode array +int ncols #I number of output image columns +real filter[ARB] #U the array of points to be modal filtered +int left[ARB] #U the array of back pointers +int right[ARB] #U the array of forward pointers + +int i, j, k, start, finish, mp, xbox, npts, nptsp1, nhalf, nlo, nhi, nzero +real sum, zlo, zhi + +begin + xbox = MOD_XBOX(mde) + npts = MOD_NPTS(mde) + nptsp1 = MOD_NPTSP1(mde) + zlo = MOD_ZLOW(mde) + zhi = MOD_ZHIGH(mde) + + start = MOD_START(mde) + finish = MOD_FINISH(mde) + mp = MOD_MP(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + # Modal filter an image line. + do i = 1, ncols - 1 { + + # Calculate the mode. + k = start + nzero = npts - nhi - nlo + nhalf = (nzero - 1) / 2 + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[i] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[i] = zhi + else + mode[i] = zlo + + # Delete points from the filter kernel. + if (filter[mp] < zlo) + nlo = nlo - 1 + else if (filter[mp] > zhi) + nhi = nhi - 1 + else + sum = sum - filter[mp] + + if (mp == start) { + start = right[mp] + left[right[mp]] = 0 + } else + right[left[mp]] = right[mp] + + if (mp == finish) { + finish = left[mp] + right[left[mp]] = nptsp1 + } else + left[right[mp]] = left[mp] + + # Update the mode kernel. + if (data[i+xbox,1] < zlo) + nlo = nlo + 1 + else if (data[i+xbox,1] > zhi) + nhi = nhi + 1 + else + sum = sum + data[i+xbox,1] + filter[mp] = data[i+xbox,1] + + # Find the point to the right of the point to be inserted. + k = start + while (k != right[finish] && filter[mp] > filter[k]) + k = right[k] + + # Insert points into the filter kernel. + if (k == start) { + left[start] = mp + left[mp] = 0 + right[mp] = start + start = mp + } else if (k == right[finish]) { + right[finish] = mp + left[mp] = finish + right[mp] = nptsp1 + finish = mp + } else { + left[mp] = left[k] + right[mp] = right[left[k]] + right[left[k]] = mp + left[k] = mp + } + + # Increment mode counter + mp = mp + 1 + if (mp > npts) + mp = 1 + } + + # Calculate the last mode. + nzero = npts - nhi - nlo + nhalf = (nzero - 1) / 2 + k = start + do j = 1, nlo + nhalf + k = right[k] + if (nzero > 0) + mode[ncols] = 3.0 * filter[k] - 2.0 * sum / nzero + else if (nlo < nhi) + mode[ncols] = zhi + else + mode[ncols] = zlo + + MOD_START(mde) = start + MOD_FINISH(mde) = finish + MOD_MP(mde) = mp + MOD_NLOW(mde) = nlo + MOD_NHIGH(mde) = nhi + MOD_SUM(mde) = sum +end + + +# MDE_YOFILTER -- Modal filter a single image line in the y direction. + +procedure mde_yofilter (mde, data, nx, ny, filter, mode, ncols) + +pointer mde #I pointer to the mode structure +real data[nx,ny] #I image data +int nx, ny #I dimensions of data +real filter[ARB] #U array containing the points to be modal filtered +real mode[ncols] #O the mode array +int ncols #I number of output image columns + +int i, j, npts, nlo, nhi +real sum, zlo, zhi + +begin + zlo = MOD_ZLOW(mde) + zhi = MOD_ZHIGH(mde) + + npts = MOD_NPTS(mde) + nlo = MOD_NLOW(mde) + nhi = MOD_NHIGH(mde) + sum = MOD_SUM(mde) + + do i = 1, ncols - 1 { + + # Calculate the new mode. + if (npts > 0) + mode[i] = 3.0 * filter[(npts+1)/2] - 2.0 * sum / npts + else if (nlo < nhi) + mode[i] = zhi + else + mode[i] = zlo + + # Update the mode kernel. + npts = 0 + nlo = 0 + nhi = 0 + sum = 0.0 + do j = 1, ny { + if (data[i+1,j] < zlo) { + nlo = nlo + 1 + next + } + if (data[i+1,j] > zhi) { + nhi = nhi + 1 + next + } + npts = npts + 1 + sum = sum + data[i+1,j] + filter[npts] = data[i+1,j] + } + + if (npts > 0) + call med_ashsrt (filter, npts) + + } + + # Calculate the last mode. + if (npts > 0) + mode[ncols] = 3.0 * filter[(npts+1)/2] - 2.0 * sum / npts + else if (nlo < nhi) + mode[ncols] = zhi + else + mode[ncols] = zlo + + # Store the results. + MOD_NPTS(mde) = npts + MOD_NLOW(mde) = nlo + MOD_NHIGH(mde) = nhi + MOD_SUM(Mde) = sum +end diff --git a/pkg/images/imfilter/src/radcnv.x b/pkg/images/imfilter/src/radcnv.x new file mode 100644 index 00000000..369b03bf --- /dev/null +++ b/pkg/images/imfilter/src/radcnv.x @@ -0,0 +1,95 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CNV_RADCNVR -- Vector convolution of a radially symmetric function. +# The output vector is equal to the sum of its initial value and the +# convolution of the input vector with the kernel. The kernel length may be an +# even or odd number. This routine assumes boundary extension on the input +# vector has been provided. For short kernels, we unroll the inner do loop +# into a single statement to reduce loop overhead. This is a modified vops +# procedure. + +procedure cnv_radcnvr (in, out, npix, kernel, knpix) + +real in[npix+knpix-1] # input vector, including boundary pixels +real out[ARB] # output vector +int npix # length of output vector +real kernel[knpix] # convolution kernel +int knpix # size of convolution kernel + +int i, j, midpoint, hknpix +real sum, k1, k2, k3 + +begin + switch (knpix) { + case 1: + k1 = kernel[1] + do i = 1, npix + out[i] = out[i] + k1 * in[i] + case 2: + k1 = kernel[1] + do i = 1, npix + out[i] = out[i] + k1 * (in[i] + in[i+1]) + case 3: + k1 = kernel[1] + k2 = kernel[2] + do i = 1, npix + out[i] = out[i] + k1 * (in[i] + in[i+2]) + k2 * in[i+1] + case 4: + k1 = kernel[1] + k2 = kernel[2] + do i = 1, npix + out[i] = out[i] + k1 * (in[i] + in[i+3]) + k2 * (in[i+1] + + in[i+2]) + case 5: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * (in[i] + in[i+4]) + k2 * (in[i+1] + + in[i+3]) + k3 * in[i+2] + case 6: + k1 = kernel[1] + k2 = kernel[2] + k3 = kernel[3] + do i = 1, npix + out[i] = out[i] + k1 * (in[i] + in[i+5]) + k2 * (in[i+1] + + in[i+4]) + k3 * (in[i+2] + in[i+3]) + default: + hknpix = knpix / 2 + midpoint = hknpix + 1 + if (mod (knpix, 2) == 1) { + do i = 1, npix { + sum = out[i] + do j = 1, hknpix + sum = sum + kernel[j] * (in[i+j-1] + in[i-j+knpix]) + out[i] = sum + kernel[midpoint] * in[i+hknpix] + } + } else { + do i = 1, npix { + sum = out[i] + do j = 1, hknpix + sum = sum + kernel[j] * (in[i+j-1] + in[i-j+knpix]) + out[i] = sum + } + } + } +end + + +# CNV_AWSUM1 -- Add two real vectors together after multiplying one of them +# by a constant. + +procedure cnv_awsum1 (a, b, c, npts, k) + +real a[ARB] # the first input vector +real b[ARB] # the second input vector +real c[ARB] # the output vector +int npts # the number of points +real k # the real constant + +int i + +begin + do i = 1, npts + c[i] = a[i] + k * b[i] +end diff --git a/pkg/images/imfilter/src/rmedian.h b/pkg/images/imfilter/src/rmedian.h new file mode 100644 index 00000000..112180c4 --- /dev/null +++ b/pkg/images/imfilter/src/rmedian.h @@ -0,0 +1,9 @@ +# Structure definition for the RMEDIAN task + +define LEN_RMEDIAN_STRUCT 10 + +define RMED_NRING Memi[$1] # the number of elements in the filter +define RMED_NLOW Memi[$1+1] # number of low rejected pixels +define RMED_NHIGH Memi[$1+2] # number of high rejected pixels +define RMED_ZLOW Memr[P2R($1+3)] # data low side rejection parameter +define RMED_ZHIGH Memr[P2R($1+4)] # data high side rejection parameter diff --git a/pkg/images/imfilter/src/rmedian.x b/pkg/images/imfilter/src/rmedian.x new file mode 100644 index 00000000..6678ff1a --- /dev/null +++ b/pkg/images/imfilter/src/rmedian.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "rmedian.h" + +# MED_MEDRING -- Median ring filter an image. + +procedure med_medring (med, im1, im2, boundary, constant, kernel, nxk, nyk) + +pointer med #I pointer to the rmedian structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension +short kernel[nxk,ARB] #I the ring filter kernel +int nxk, nyk #I dimensions of the kernel + + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, filter +pointer impl2r() +errchk impl2r, med_buf, med_remedfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2, nyk / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the points to be medianed. + call malloc (filter, RMED_NRING(med), TY_REAL) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + nyk = 1 + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1, 1) + nxk / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - nyk / 2 + line2 = line + nyk / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call med_buf (im1, col1, col2, line1, line2, inbuf) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Median filter the image line. + call med_remedfilter (med, Memr[inbuf], ncols, nlines, Memr[outbuf], + int (IM_LEN(im2, 1)), Memr[filter], kernel, nxk, nyk) + } + + # Free space. + call mfree (filter, TY_REAL) + call mfree (inbuf, TY_REAL) +end + + +# MED_REMEDFILTER -- Run the median window forward. + +procedure med_remedfilter (med, data, nx, ny, medline, ncols, filter, + kernel, xbox, ybox) + +pointer med #I pointer to the rmedian structure +real data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O the output array of medians +int ncols #I length of output image line +real filter[ARB] #U the medianing filter +short kernel[xbox,ARB] #U the ring filter kernel +int xbox, ybox #U the dimensions of the kernel + +int i, j, k, nring, npts, nlo, nhi +real zlo, zhi +real asokr() + +begin + nring = RMED_NRING(med) + zlo = RMED_ZLOW(med) + zhi = RMED_ZHIGH(med) + + # Loop over the data columns. + do i = 1, ncols { + + # Load the filter. + nlo = 0 + nhi = 0 + npts = 0 + do j = 1, ybox { + do k = i, i + xbox - 1 { + if (kernel[k-i+1,j] == 0) + next + if (data[k,j] < zlo) { + nlo = nlo + 1 + next + } + if (data[k,j] > zhi) { + nhi = nhi + 1 + next + } + npts = npts + 1 + filter[npts] = data[k,j] + } + } + + # Compute the median. + if (npts > 0) + medline[i] = asokr (filter, npts, (npts+1)/2) + else if (nlo < nhi) + medline[i] = zhi + else + medline[i] = zlo + } +end diff --git a/pkg/images/imfilter/src/rmode.h b/pkg/images/imfilter/src/rmode.h new file mode 100644 index 00000000..ffd8a4f1 --- /dev/null +++ b/pkg/images/imfilter/src/rmode.h @@ -0,0 +1,9 @@ +# Structure definition for the RMODE task + +define LEN_RMODE_STRUCT 10 + +define RMOD_NRING Memi[$1] # the number of elements in the filter +define RMOD_NLOW Memi[$1+1] # number of low rejected pixels +define RMOD_NHIGH Memi[$1+2] # number of high rejected pixels +define RMOD_ZLOW Memr[P2R($1+3)] # data low side rejection parameter +define RMOD_ZHIGH Memr[P2R($1+4)] # data high side rejection parameter diff --git a/pkg/images/imfilter/src/rmode.x b/pkg/images/imfilter/src/rmode.x new file mode 100644 index 00000000..b16f5625 --- /dev/null +++ b/pkg/images/imfilter/src/rmode.x @@ -0,0 +1,131 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "rmode.h" + +# MED_MODRING -- Modal ring filter an image. + +procedure med_modring (med, im1, im2, boundary, constant, kernel, nxk, nyk) + +pointer med #I pointer to the rmedian structure +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int boundary #I boundary extension type +real constant #I constant for constant boundary extension +short kernel[nxk,ARB] #I the ring filter kernel +int nxk, nyk #I dimensions of the kernel + + +int col1, col2, ncols, line, line1, line2, nlines +pointer inbuf, outbuf, filter +pointer impl2r() +errchk impl2r, med_buf, med_remedfilter + +begin + # Set the image boundary extension parameters. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2, nyk / 2)) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for the points to be medianed. + call malloc (filter, RMOD_NRING(med), TY_REAL) + + # Check for 1D images. + if (IM_NDIM(im1) == 1) + nyk = 1 + + # Initialize input image buffer. + inbuf = NULL + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1, 1) + nxk / 2 + ncols = col2 - col1 + 1 + + # Generate the output image line by line. + do line = 1, IM_LEN(im2, 2) { + + # Define the range of lines to read. + line1 = line - nyk / 2 + line2 = line + nyk / 2 + nlines = line2 - line1 + 1 + + # Read in the appropriate range of image lines. + call med_buf (im1, col1, col2, line1, line2, inbuf) + + # Get output image line. + outbuf = impl2r (im2, line) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Median filter the image line. + call med_romodfilter (med, Memr[inbuf], ncols, nlines, Memr[outbuf], + int (IM_LEN(im2, 1)), Memr[filter], kernel, nxk, nyk) + + } + + # Free space. + call mfree (filter, TY_REAL) + call mfree (inbuf, TY_REAL) +end + + +# MED_ROMODFILTER -- Run the median window forward. + +procedure med_romodfilter (med, data, nx, ny, medline, ncols, filter, + kernel, xbox, ybox) + +pointer med #I pointer to the fmedian structure +real data[nx,ny] #I buffer of image data +int nx, ny #I dimensions of image buffer +real medline[ncols] #O the output array of medians +int ncols #I length of output image line +real filter[ARB] #U the medianing filter +short kernel[xbox,ARB] #U the ring filter kernel +int xbox, ybox #U the dimensions of the kernel + +int i, j, k, nring, npts, nlo, nhi +real sum, zlo, zhi +real asokr() + +begin + nring = RMOD_NRING(med) + zlo = RMOD_ZLOW(med) + zhi = RMOD_ZHIGH(med) + + # Loop over the data columns. + do i = 1, ncols { + + # Load the filter. + nlo = 0 + nhi = 0 + npts = 0 + sum = 0.0 + do j = 1, ybox { + do k = i, i + xbox - 1 { + if (kernel[k-i+1,j] == 0) + next + if (data[k,j] < zlo) { + nlo = nlo + 1 + next + } + if (data[k,j] > zhi) { + nhi = nhi + 1 + next + } + sum = sum + data[k,j] + npts = npts + 1 + filter[npts] = data[k,j] + } + } + + # Compute the median. + if (npts > 0) + medline[i] = 3.0 * asokr (filter, npts, (npts+1)/2) - 2.0 * + sum / npts + else if (nlo < nhi) + medline[i] = zhi + else + medline[i] = zlo + } +end + diff --git a/pkg/images/imfilter/src/runmed.x b/pkg/images/imfilter/src/runmed.x new file mode 100644 index 00000000..749cea48 --- /dev/null +++ b/pkg/images/imfilter/src/runmed.x @@ -0,0 +1,506 @@ +include +include +include + +define OUTTYPES "|filter|difference|ratio|" +define OT_NTYPES 3 # Number of output types +define OT_FILTER 1 # Output filter values +define OT_DIFF 2 # Output difference +define OT_RATIO 3 # Output ratio + +define STORETYPES "|real|short|" + +define NSAMPLE 100000 # Number of pixels to sample for mode +define NLINES 10 # Minimum number of lines to sample +define FRAC 0.9 # Fraction of sorted sample for mean + + +# RUNMED -- Apply running median to a list of images. + +procedure runmed (input, output, window, masks, inmaskkey, outmaskkey, + outtype, exclude, nclip, navg, scale, normscale, outscale, blank, + storetype, verbose) + +pointer input #I List of input images +pointer output #I List of output images +int window #I Filter window +pointer masks #I List of output masks +char inmaskkey[ARB] #I Input mask keyword +char outmaskkey[ARB] #I Output mask keyword +char outtype[ARB] #I Output type +bool exclude #I Exclude input image? +real nclip #I Clipping factor +int navg #I Number of values to average +char scale[ARB] #I Scale specification +bool normscale #I Normalize scales to first scale? +bool outscale #I Scale output? +real blank #I Blank values +char storetype[ARB] #I Storage type +bool verbose #I Verbose? + +int i, j, nims, nc, nl, iindex, oindex, eindex, stat, halfwin, ot, stype +int fd, len[IM_MAXDIM] +short nused +real iscl, iscl1, oscl, val, mean, sigma, median, mode +pointer in, im, out, om, idata, imdata, imdata1, odata, omdata, omdata1, hdr, rm +pointer sp, inname, outname, imtemp, imname, omname +pointer iline, imline, oline, omline, hdrs, scales, sample, str, rms + +bool streq(), strne(), aveqi() +int open(), fscan(), nscan(), nowhite(), strdic() +int imtlen(), imtrgetim() +int xt_sampler(), xt_samples(), imgnlr(), impnlr(), imgnls(), impnls() +real imgetr(), rm_med(), rm_gmed(), rm_gdata() +pointer immap(), yt_mappm(), rm_open() +errchk immap, yt_mappm + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Check input data for errors. + nims = imtlen (input) + if (nims < 0) + call error (1, "No input images specified") + if (imtlen (output) != nims) + call error (2, "Number of input and output images don't agree") + if (window < 0) + call error (3, "Window size error") + if (window > nims) + call error (4, "Window size exceeds number of images") + if (imtlen (masks) > 0 && imtlen (masks) != nims) + call error (5, "Number of output masks and images don't agree") + ot = strdic (outtype, Memc[str], SZ_LINE, OUTTYPES) + if (ot < 1 || ot > OT_NTYPES) + call error (7, "Unknown output type") + if (navg < 0) + call error(8, + "Number of central pixels to average must be positive") + if (strne (scale, "none") && strne (scale, "mode") && + scale[1] != '!' && scale[1] != '@') + call error (11, "Bad scale specification") + if (IS_INDEFR(blank)) + call error (12, "Blank value may not be INDEF") + switch (strdic (storetype, Memc[str], SZ_LINE, STORETYPES)) { + case 1: + stype = TY_REAL + case 2: + stype = TY_SHORT + default: + call error (14, "Unsupported storage type") + } + + # Open and check scale file if one is specified. + if (scale[1] == '@') { + fd = open (scale[2], READ_ONLY, TEXT_FILE) + i = 0 + while (fscan (fd) != EOF) { + i = i + 1 + call gargr (val) + if (nscan() != 1 || i > nims) { + call close (fd) + call error (13, "Scale file error") + } + } + call seek (fd, BOF) + } else + fd = NULL + + # Allocate memory. + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (omname, SZ_FNAME, TY_CHAR) + call salloc (iline, IM_MAXDIM, TY_LONG) + call salloc (imline, IM_MAXDIM, TY_LONG) + call salloc (oline, IM_MAXDIM, TY_LONG) + call salloc (omline, IM_MAXDIM, TY_LONG) + call salloc (hdrs, window, TY_POINTER) + call salloc (scales, window, TY_REAL) + if (streq (scale, "mode")) + call salloc (sample, NSAMPLE, TY_STRUCT) + + # Initialize + halfwin = window / 2 + call aclri (Memi[hdrs], window) + call amovkr (1., Memr[scales], window) + imdata1 = NULL + omdata1 = NULL + oindex = 0 + eindex = 0 + if (verbose) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Loop through data. + do iindex = 1, nims { + # Setup input image and save copy of header. + stat = imtrgetim (input, iindex, Memc[inname], SZ_FNAME) + if (verbose) { + call printf (" Reading %s ...\n") + call pargstr (Memc[inname]) + } + in = immap (Memc[inname], READ_ONLY, 0) + im = NULL + if (nowhite (inmaskkey, Memc[str], SZ_LINE) > 0) { + ifnoerr (call imgstr (in, Memc[str], Memc[imname], SZ_FNAME)) { + call printf (" Reading mask %s ...\n") + call pargstr (Memc[imname]) + #im = immap (Memc[imname], READ_ONLY, 0) + im = yt_mappm (Memc[imname], in, "logical", + Memc[imname], SZ_FNAME) + } + } + + j = mod (iindex, window) + hdr = Memi[hdrs+j] + call mfree (hdr, TY_STRUCT) + call malloc (hdr, LEN_IMDES+IM_HDRLEN(in)+1, TY_STRUCT) + call amovi (Memi[in], Memi[hdr], LEN_IMDES) + call amovi (IM_MAGIC(in), IM_MAGIC(hdr), IM_HDRLEN(in)+1) + call strcpy (Memc[inname], IM_NAME(hdr), SZ_IMNAME) + Memi[hdrs+j] = hdr + + # Check image size. + if (iindex == 1) + call amovi (IM_LEN(in,1), len, IM_MAXDIM) + else if (!aveqi (IM_LEN(in,1), len, IM_MAXDIM)) + call error (21, "Image sizes are not the same") + if (im != NULL) { + if (!aveqi (IM_LEN(im,1), len, IM_MAXDIM)) + call error (21, "Mask size not the same") + } else if (imdata1 == NULL) { + call salloc (imdata1, IM_LEN(in,1), TY_SHORT) + call aclrs (Mems[imdata1], IM_LEN(in,1)) + } + + # Initialize. + if (iindex == 1) { + nc = IM_LEN(in,1) + nl = 1 + do i = 2, IM_NDIM(in) + nl = nl * len[i] + + # Memory is allocated in blocks of number of columns. + call salloc (rms, nl, TY_POINTER) + do j = 1, nl { + rm = rm_open (window, "median", nc, stype) + Memi[rms+j-1] = rm + } + } + + # Go through input image and create output image. + + # Set scale factor. + if (fd != NULL) { + stat = fscan (fd) + call gargr (iscl) + if (iscl == 0.) + iscl = 1. + } else if (scale[1] == '!') { + iscl = imgetr (in, scale[2]) + if (iscl == 0.) + iscl = 1. + } else if (streq (scale, "mode")) { + if (IM_PIXTYPE(in) == TY_SHORT) { + i = xt_samples (in, im, Mems[P2S(sample)], NSAMPLE, NLINES) + call xt_stats (Mems[P2S(sample)], i, FRAC, + mean, sigma, median, mode) + } else { + i = xt_sampler (in, im, Memr[sample], NSAMPLE, NLINES) + call xt_statr (Memr[sample], i, FRAC, + mean, sigma, median, mode) + } + if (verbose) { + call printf(" nsample=%d, mean=%g, median=%g, mode=%g\n") + call pargi (i) + call pargr (mean) + call pargr (median) + call pargr (mode) + } + if (mode != 0.) + iscl = 1. / mode + else + iscl = 1. + } else + iscl = 1. + + if (iindex == 1) + iscl1 = iscl + if (normscale) + iscl = iscl / iscl1 + if (verbose && strne (scale, "none")) { + call printf (" scale = %g\n") + call pargr (iscl) + } + Memr[scales+mod(iindex,window)] = iscl + + # Do initial accumulation. + if (iindex < window) { + call amovkl (long(1), Meml[iline], IM_MAXDIM) + call amovkl (long(1), Meml[imline], IM_MAXDIM) + do j = 1, nl { + rm = Memi[rms+j-1] + if (im != NULL) + stat = imgnls (im, imdata, Meml[imline]) + else + imdata = imdata1 + if (IM_PIXTYPE(in) == TY_SHORT) { + stat = imgnls (in, idata, Meml[iline]) + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, 0, iindex, + iscl*Mems[idata+i-1], Mems[imdata+i-1], + nused) + call rm_pack (rm, i) + } + } else { + stat = imgnlr (in, idata, Meml[iline]) + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, 0, iindex, + iscl*Memr[idata+i-1], Mems[imdata+i-1], + nused) + call rm_pack (rm, i) + } + } + } + if (im != NULL) + call imunmap (im) + call imunmap (in) + next + } + + # Setup output image. + oindex = oindex + 1 + if (exclude) + eindex = oindex + stat = imtrgetim (output, oindex, Memc[outname], SZ_FNAME) + if (verbose) { + call printf (" Writing %s ...\n") + call pargstr (Memc[outname]) + } + hdr = Memi[hdrs+mod(oindex,window)] + call xt_mkimtemp (IM_NAME(hdr), Memc[outname], Memc[imtemp], + SZ_FNAME) + out = immap (Memc[outname], NEW_COPY, hdr) + IM_PIXTYPE(out) = TY_REAL + + # Setup output mask. + stat = imtrgetim (masks, oindex, Memc[str], SZ_LINE) + if (stat != EOF) { + call xt_maskname (Memc[str], "pl", NEW_IMAGE, Memc[omname], + SZ_FNAME) + if (verbose) { + call printf (" Writing mask %s ...\n") + call pargstr (Memc[omname]) + } + om = immap (Memc[omname], NEW_COPY, hdr) + if (nowhite (outmaskkey, Memc[str], SZ_LINE) > 0) + call imastr (out, Memc[str], Memc[omname]) + } else + om = NULL + if (omdata1 == NULL) + call salloc (omdata1, IM_LEN(in,1), TY_SHORT) + + if (outscale) + oscl = 1 + else + oscl = 1 / Memr[scales+mod(oindex,window)] + + # Add input data and create output data. + call amovkl (long(1), Meml[iline], IM_MAXDIM) + call amovkl (long(1), Meml[imline], IM_MAXDIM) + call amovkl (long(1), Meml[oline], IM_MAXDIM) + call amovkl (long(1), Meml[omline], IM_MAXDIM) + do j = 1, nl { + stat = impnlr (out, odata, Meml[oline]) + if (im != NULL) + stat = imgnls (im, imdata, Meml[imline]) + else + imdata = imdata1 + if (om != NULL) + stat = impnls (om, omdata, Meml[omline]) + else + omdata = omdata1 + + rm = Memi[rms+j-1] + if (IM_PIXTYPE(in) == TY_SHORT) { + stat = imgnls (in, idata, Meml[iline]) + switch (ot) { + case OT_FILTER: + do i = 1, nc { + call rm_unpack (rm, i) + Memr[odata+i-1] = oscl * rm_med (rm, nclip, navg, + blank, eindex, iindex, iscl*Mems[idata+i-1], + Mems[imdata+i-1], Mems[omdata+i-1]) + call rm_pack (rm, i) + } + case OT_DIFF: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, eindex, + iindex, iscl*Mems[idata+i-1], Mems[imdata+i-1], + Mems[omdata+i-1]) + Memr[odata+i-1] = + oscl * (rm_gdata (rm, oindex) - val) + call rm_pack (rm, i) + } + case OT_RATIO: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, eindex, + iindex, iscl*Mems[idata+i-1], Mems[imdata+i-1], + Mems[omdata+i-1]) + if (val != 0.) + Memr[odata+i-1] = rm_gdata (rm, oindex) / val + else + Memr[odata+i-1] = blank + call rm_pack (rm, i) + } + } + } else { + stat = imgnlr (in, idata, Meml[iline]) + switch (ot) { + case OT_FILTER: + do i = 1, nc { + call rm_unpack (rm, i) + Memr[odata+i-1] = oscl * rm_med (rm, nclip, navg, + blank, eindex, iindex, iscl*Memr[idata+i-1], + Mems[imdata+i-1], Mems[omdata+i-1]) + call rm_pack (rm, i) + } + case OT_DIFF: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, eindex, + iindex, iscl*Memr[idata+i-1], Mems[imdata+i-1], + Mems[omdata+i-1]) + Memr[odata+i-1] = + oscl * (rm_gdata (rm, oindex) - val) + call rm_pack (rm, i) + } + case OT_RATIO: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_med (rm, nclip, navg, blank, eindex, + iindex, iscl*Memr[idata+i-1], Mems[imdata+i-1], + Mems[omdata+i-1]) + if (val != 0.) + Memr[odata+i-1] = rm_gdata (rm, oindex) / val + else + Memr[odata+i-1] = blank + call rm_pack (rm, i) + } + } + } + } + + if (om != NULL) + call imunmap (om) + call imunmap (out) + call xt_delimtemp (Memc[outname], Memc[imtemp]) + if (im != NULL) + call imunmap (im) + call imunmap (in) + + # Do endpoints. + while (oindex <= halfwin || + (oindex >= nims - (window-1)/2 && oindex < nims)) { + + oindex = oindex + 1 + if (exclude) + eindex = oindex + stat = imtrgetim (output, oindex, Memc[outname], SZ_FNAME) + if (verbose) { + call printf (" Writing %s ...\n") + call pargstr (Memc[outname]) + } + hdr = Memi[hdrs+mod(oindex,window)] + call xt_mkimtemp (IM_NAME(hdr), Memc[outname], Memc[imtemp], + SZ_FNAME) + out = immap (Memc[outname], NEW_COPY, hdr) + IM_PIXTYPE(out) = TY_REAL + + stat = imtrgetim (masks, oindex, Memc[str], SZ_LINE) + if (stat != EOF) { + call xt_maskname (Memc[str], "pl", NEW_IMAGE, Memc[omname], + SZ_FNAME) + if (verbose) { + call printf (" Writing mask %s ...\n") + call pargstr (Memc[omname]) + } + om = immap (Memc[omname], NEW_COPY, hdr) + if (nowhite (outmaskkey, Memc[str], SZ_LINE) > 0) + call imastr (out, Memc[str], Memc[omname]) + } else + om = NULL + if (omdata1 == NULL) + call salloc (omdata1, IM_LEN(in,1), TY_SHORT) + + if (outscale) + oscl = 1 + else + oscl = 1 / Memr[scales+mod(oindex,window)] + + call amovkl (long(1), Meml[oline], IM_MAXDIM) + call amovkl (long(1), Meml[omline], IM_MAXDIM) + do j = 1, nl { + stat = impnlr (out, odata, Meml[oline]) + if (om != NULL) + stat = impnls (om, omdata, Meml[omline]) + else + omdata = omdata1 + + rm = Memi[rms+j-1] + switch (ot) { + case OT_FILTER: + do i = 1, nc { + call rm_unpack (rm, i) + Memr[odata+i-1] = oscl * rm_gmed (rm, nclip, navg, + blank, eindex, Mems[omdata+i-1]) + call rm_pack (rm, i) + } + case OT_DIFF: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_gmed (rm, nclip, navg, blank, eindex, + Mems[omdata+i-1]) + Memr[odata+i-1] = oscl * + (rm_gdata (rm, oindex) - val) + call rm_pack (rm, i) + } + case OT_RATIO: + do i = 1, nc { + call rm_unpack (rm, i) + val = rm_gmed (rm, nclip, navg, blank, eindex, + Mems[omdata+i-1]) + if (val != 0.) + Memr[odata+i-1] = rm_gdata (rm, oindex) / val + else + Memr[odata+i-1] = blank + call rm_pack (rm, i) + } + } + } + + if (om != NULL) + call imunmap (om) + call imunmap (out) + call xt_delimtemp (Memc[outname], Memc[imtemp]) + } + } + + # Finish up. + if (fd != NULL) + call close (fd) + do j = 1, nl { + rm = Memi[rms+j-1] + call rm_close (rm) + } + do i = 1, window { + hdr = Memi[hdrs+mod(i,window)] + call mfree (hdr, TY_STRUCT) + } + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_boxcar.x b/pkg/images/imfilter/src/t_boxcar.x new file mode 100644 index 00000000..bf06250c --- /dev/null +++ b/pkg/images/imfilter/src/t_boxcar.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# T_BOXCAR -- Boxcar smooth a list of IRAF images + +procedure t_boxcar() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list + +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image + +int boundary # Type of boundary extension +real constant # Constant boundary extension + +char str[SZ_LINE], imtemp[SZ_FNAME] +int list1, list2, kxdim, kydim +pointer im1, im2 + +int imtopen(), imtgetim(), imtlen(), clgeti(), clgwrd() +pointer immap() +real clgetr() + +errchk cnv_boxcar + +begin + # Get task parameters + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + + # Get filter parameters + kxdim = clgeti ("xwindow") + kydim = clgeti ("ywindow") + + # Get boundary extension parameters + boundary = clgwrd ("boundary", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + + # Check list lengths + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Boxcar smooth the images + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Make temporary image + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + # Open images + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + # Boxcar smooth an image + iferr { + switch (IM_NDIM(im1)) { + case 1: + kydim = 1 + case 2: + ; + default: + call error (0, "T_CONVOLVE: Image dimension > 2.") + } + call cnv_boxcar (im1, im2, kxdim, kydim, boundary, constant) + } then { + call eprintf ("Error smoothing image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (image2) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (image2, imtemp) + } + + } + + # close images + call imtclose (list1) + call imtclose (list2) +end diff --git a/pkg/images/imfilter/src/t_convolve.x b/pkg/images/imfilter/src/t_convolve.x new file mode 100644 index 00000000..d14d679e --- /dev/null +++ b/pkg/images/imfilter/src/t_convolve.x @@ -0,0 +1,302 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define SZ_KERNEL SZ_LINE + + +# T_CONVOLVE -- Convolve a list of IRAF images with an arbitrary kernel. + +procedure t_convolve() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image +int boundary # Type of boundary extension +real constant # Constant boundary extension +int bilinear # Bilinear kernel +int radsym # Radially symmetric kernel? +int delim # record delimiter for files + +char str[SZ_LINE], imtemp[SZ_FNAME] +int list1, list2, kxdim, kydim, dummy +pointer sp, im1, im2, kername, xkername, ykername, kernel, xkernel, ykernel + +bool clgetb() +char clgetc() +int imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +pointer immap() +real clgetr() +errchk cnv_convolve + +begin + # Allocate temporary working space. + call smark (sp) + call salloc (kername, SZ_LINE, TY_CHAR) + call salloc (xkername, SZ_LINE, TY_CHAR) + call salloc (ykername, SZ_LINE, TY_CHAR) + + # Get the input and output image parameters. + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + + # Get the kernel characteristics. + bilinear = btoi (clgetb ("bilinear")) + if (bilinear == NO) + call clgstr ("kernel", Memc[kername], SZ_LINE) + else { + call clgstr ("xkernel", Memc[xkername], SZ_LINE) + call clgstr ("ykernel", Memc[ykername], SZ_LINE) + } + radsym = btoi (clgetb ("radsym")) + delim = int (clgetc ("row_delimiter")) + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + + # Check the list lengths. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Fetch and decode the kernel. + kernel = NULL + xkernel = NULL + ykernel = NULL + if (bilinear == NO) { + iferr (call cnv_kernel (Memc[kername], SZ_LINE, delim, kernel, + kxdim, kydim)) + call erract (EA_FATAL) + } else { + iferr (call cnv_kernel (Memc[xkername], SZ_LINE, delim, xkernel, + kxdim, dummy)) + call erract (EA_FATAL) + if (dummy != 1) + call error (0, + "T_CONVOLVE: Error decoding the bilinear x dimension kernel") + iferr (call cnv_kernel (Memc[ykername], SZ_LINE, delim, ykernel, + kydim, dummy)) + call erract (EA_FATAL) + if (dummy != 1) + call error (0, + "T_CONVOLVE: Error decoding the bilinear y dimension kernel") + } + + call sfree (sp) + + # Convolve the images in the list with the kernel. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Make a temporary image name. + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + # Open the input and output images. + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + # Convolve each image with the kernel. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + if (kydim > 1) + call error (0, + "T_CONVOLVE: Kernel dimension higher than image dimension.") + case 2: + ; + default: + call error (0, "T_CONVOLVE: Image dimension > 2.") + } + + if (bilinear == NO) + call cnv_convolve (im1, im2, Memr[kernel], kxdim, kydim, + boundary, constant, radsym) + else + call cnv_xyconvolve (im1, im2, Memr[xkernel], kxdim, + Memr[ykernel], kydim, boundary, constant, radsym) + + } then { + call eprintf ("Error convolving image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (image2) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (image2, imtemp) + } + } + + # Close the image lists. + call imtclose (list1) + call imtclose (list2) + + # Free the kernel space. + if (kernel != NULL) + call mfree (kernel, TY_REAL) + if (xkernel != NULL) + call mfree (xkernel, TY_REAL) + if (ykernel != NULL) + call mfree (ykernel, TY_REAL) +end + + +# CNV_KERNEL -- Make the kernel. If kername begins with a digit, a period or +# a minus sign CNV_KERNEL opens the kername string as a file and passes +# the file descriptor to the decoding routines. Otherwise CNV_KERNEL tries +# to open a text file on disk. + +procedure cnv_kernel (kername, maxch, delim, kernel, nx, ny) + +char kername[maxch] # kernal +int maxch # maximum length of kername +int delim # delimiter for kernel rows +pointer kernel # Gaussian kernel +int nx, ny # dimensions of the kernel + +int fd +int access(), stropen(), open() + +begin + if (access (kername, READ_ONLY, TEXT_FILE) == YES) { + fd = open (kername, READ_ONLY, TEXT_FILE) + call cnv_decode_kernel (fd, kernel, nx, ny, delim) + call cnv_rowflip (Memr[kernel], nx, ny) + call close (fd) + } else { + fd = stropen (kername, maxch, READ_ONLY) + call cnv_decode_kernel (fd, kernel, nx, ny, delim) + call strclose (fd) + } +end + + +# CNV_ROWFLIP -- Column flip a 2D matrix in place + +procedure cnv_rowflip (a, nx, ny) + +real a[nx,ny] # matrix to be flipped +int nx, ny # dimensions of a + +int i, j, nhalf, ntotal +real temp + +begin + nhalf = ny / 2 + ntotal = ny + 1 + + do i = 1, nx { + do j = 1, nhalf { + temp = a[i,j] + a[i,j] = a[i,ntotal-j] + a[i,ntotal-j] = temp + } + } +end + + +# CNV_DECODE_KERNEL -- Procedure to decode the kernel + +procedure cnv_decode_kernel (fd, kernel, nx, ny, delim) + +int fd # file descriptor +pointer kernel # pointer to kernel +int nx, ny # kernel dimensions +int delim # kernel row delimiter + +pointer sp, line +int sz_kernel, kp, lp, minnx, maxnx, nchars +int getline(), ctor() + +begin + # Allocate space for the line buffer. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Initialize row and column counters and the kernel element counter. + kp = 0 + nx = 0 + ny = 0 + minnx = MAX_INT + maxnx = -MAX_INT + kernel = NULL + + # Decode the kernel. + nchars = getline (fd, Memc[line]) + while (nchars != EOF) { + + # Decode each kernel line. + for (lp = 1; lp <= nchars; ) { + + # Check to see that kernel is big enough. + if (kernel == NULL) { + sz_kernel = SZ_KERNEL + call malloc (kernel, sz_kernel, TY_REAL) + } else if (kp > sz_kernel) { + sz_kernel = sz_kernel + SZ_KERNEL + call realloc (kernel, sz_kernel, TY_REAL) + } + + # Decode the kernel elements one by one. + if (Memc[line+lp-1] == delim) { + minnx = min (minnx, nx) + maxnx = max (maxnx, nx) + nx = 0 + ny = ny + 1 + lp = lp + 1 + + } else if (Memc[line+lp-1] == '\n' || + IS_WHITE(Memc[line+lp-1]) || Memc[line+lp-1] == ',') { + lp = lp + 1 + + } else { + if (ctor (Memc[line], lp, Memr[kernel+kp]) == 0) { + call sfree (sp) + call error (0, "CNV_DECODE_KERNEL: Invalid kernel.") + } + kp = kp + 1 + nx = nx + 1 + } + } + + # Get next line. + nchars = getline (fd, Memc[line]) + } + + # Quit if there are no valid elements in the kernel. + if (kp <= 0) + call error (0, "CNV_DECODE_KERNEL: Invalid kernel.") + + # Last delimiter is not necessary. + if (nx != 0) { + minnx = min (minnx, nx) + maxnx = max (maxnx, nx) + ny = ny + 1 + } + + # Free temporary space. + call sfree (sp) + + # Test that the kernel is the correct size. + if (minnx != maxnx) { + call error (0, "CNV_KERNEL: Kernel rows are different lengths.") + } else if ((kp != minnx * ny) || (kp != maxnx * ny)) { + call error (0, "CNV_KERNEL: Incorrect number of kernel rows.") + } else { + call realloc (kernel, kp, TY_REAL) + nx = minnx + } +end diff --git a/pkg/images/imfilter/src/t_fmedian.x b/pkg/images/imfilter/src/t_fmedian.x new file mode 100644 index 00000000..b2a0a2ad --- /dev/null +++ b/pkg/images/imfilter/src/t_fmedian.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmedian.h" + +# T_FMEDIAN -- Median filter a list of images in x and y. + +procedure t_fmedian() + +bool verbose +int list1, list2, xwindow, ywindow, boundary +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str, fmd, im1, im2 +real constant + +bool clgetb(), fp_equalr() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +pointer immap() +real clgetr() +errchk fmd_medbox + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allcoate space for the fmedian structure. + call calloc (fmd, LEN_FMEDIAN_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the window size. + xwindow = clgeti ("xwindow") + ywindow = clgeti ("ywindow") + + # Get the quantization parameters. + FMED_Z1(fmd) = clgetr ("zmin") + FMED_Z2(fmd) = clgetr ("zmax") + FMED_ZLOW(fmd) = clgetr ("zloreject") + FMED_ZHIGH(fmd) = clgetr ("zhireject") + FMED_HMIN(fmd) = clgeti ("hmin") + FMED_HMAX(fmd) = clgeti ("hmax") + FMED_UNMAP(fmd) = btoi (clgetb ("unmap")) + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Median filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (mod (xwindow, 2) == 0) + FMED_XBOX(fmd) = xwindow + 1 + else + FMED_XBOX(fmd) = xwindow + if (mod (ywindow, 2) == 0) + FMED_YBOX(fmd) = ywindow + 1 + else + FMED_YBOX(fmd) = ywindow + + if (verbose) { + call printf ("%dx%d Box median filter %s to %s\n") + call pargi (FMED_XBOX(fmd)) + call pargi (FMED_YBOX(fmd)) + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + # Find input image max and min if necessary. + if (IS_INDEFR(FMED_Z1(fmd)) || IS_INDEFR(FMED_Z2(fmd))) + call fmd_maxmin (im1, FMED_XBOX(fmd), FMED_YBOX(fmd), + boundary, constant, FMED_ZMIN(fmd), FMED_ZMAX(fmd)) + + if (verbose) { + if (! fp_equalr (FMED_Z1(fmd), real(FMED_HMIN(fmd))) && + ! fp_equalr (FMED_Z2(fmd), real(FMED_HMAX(fmd)))) { + call printf ( + " Pixels from %g to %g mapped to integers from %d to %d\n") + if (IS_INDEFR(FMED_Z1(fmd))) + call pargr (FMED_ZMIN(fmd)) + else + call pargr (FMED_Z1(fmd)) + if (IS_INDEFR(FMED_Z2(fmd))) + call pargr (FMED_ZMAX(fmd)) + else + call pargr (FMED_Z2(fmd)) + call pargi (FMED_HMIN(fmd)) + call pargi (FMED_HMAX(fmd)) + } + if (! IS_INDEFR(FMED_ZLOW(fmd)) || + ! IS_INDEFR(FMED_ZHIGH(fmd))) { + call printf ( + " Pixels < %g or > %g excluded from the median filter\n") + call pargr (FMED_ZLOW(fmd)) + call pargr (FMED_ZHIGH(fmd)) + } + call flush (STDOUT) + } + + # Median filter the image. + iferr { + call fmd_medbox (fmd, im1, im2, boundary, constant) + } then { + call eprintf ("Error median filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (fmd, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_fmode.x b/pkg/images/imfilter/src/t_fmode.x new file mode 100644 index 00000000..cf280ed2 --- /dev/null +++ b/pkg/images/imfilter/src/t_fmode.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "fmode.h" + +# T_FMODE -- Modal filter a list of images in x and y. + +procedure t_fmode() + +bool verbose +int list1, list2, xwindow, ywindow, boundary +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str, fmd, im1, im2 +real constant + +bool clgetb(), fp_equalr() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +pointer immap() +real clgetr() +errchk fmd_modbox + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate space for the fmode structure. + call calloc (fmd, LEN_FMODE_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the window sizes. + xwindow = clgeti ("xwindow") + ywindow = clgeti ("ywindow") + + # Get the quantization parameters. + FMOD_Z1(fmd) = clgetr ("zmin") + FMOD_Z2(fmd) = clgetr ("zmax") + FMOD_ZLOW(fmd) = clgetr ("zloreject") + FMOD_ZHIGH(fmd) = clgetr ("zhireject") + FMOD_HMIN(fmd) = clgeti ("hmin") + FMOD_HMAX(fmd) = clgeti ("hmax") + FMOD_UNMAP(fmd) = btoi (clgetb ("unmap")) + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Modal filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (mod (xwindow, 2) == 0) + FMOD_XBOX(fmd) = xwindow + 1 + else + FMOD_XBOX(fmd) = xwindow + if (mod (ywindow, 2) == 0) + FMOD_YBOX(fmd) = ywindow + 1 + else + FMOD_YBOX(fmd) = ywindow + + if (verbose) { + call printf ("%dx%d Box modal filter %s to %s\n") + call pargi (FMOD_XBOX(fmd)) + call pargi (FMOD_YBOX(fmd)) + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + # Find input image max and min if necessary. + if (IS_INDEFR(FMOD_Z1(fmd)) || IS_INDEFR(FMOD_Z2(fmd))) + call fmd_maxmin (im1, FMOD_XBOX(fmd), FMOD_YBOX(fmd), + boundary, constant, FMOD_ZMIN(fmd), FMOD_ZMAX(fmd)) + + if (verbose) { + if (! fp_equalr (FMOD_Z1(fmd), real(FMOD_HMIN(fmd))) && + ! fp_equalr (FMOD_Z2(fmd), real(FMOD_HMAX(fmd)))) { + call printf ( + " Pixels from %g to %g mapped to integers from %d to %d\n") + if (IS_INDEFR(FMOD_Z1(fmd))) + call pargr (FMOD_ZMIN(fmd)) + else + call pargr (FMOD_Z1(fmd)) + if (IS_INDEFR(FMOD_Z2(fmd))) + call pargr (FMOD_ZMAX(fmd)) + else + call pargr (FMOD_Z2(fmd)) + call pargi (FMOD_HMIN(fmd)) + call pargi (FMOD_HMAX(fmd)) + } + if (! IS_INDEFR(FMOD_ZLOW(fmd)) || + ! IS_INDEFR(FMOD_ZHIGH(fmd))) { + call printf ( + " Pixels < %g or > %g excluded from the modal filter\n") + call pargr (FMOD_ZLOW(fmd)) + call pargr (FMOD_ZHIGH(fmd)) + } + call flush (STDOUT) + } + + # Modal filter the image. + iferr { + call fmd_modbox (fmd, im1, im2, boundary, constant) + } then { + call eprintf ("Error modal filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (fmd, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_frmedian.x b/pkg/images/imfilter/src/t_frmedian.x new file mode 100644 index 00000000..969ee839 --- /dev/null +++ b/pkg/images/imfilter/src/t_frmedian.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "frmedian.h" + +# T_FRMEDIAN -- Ring median filter a list of images in x and y. + +procedure t_frmedian() + +bool verbose +int list1, list2, boundary, nxk, nyk +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str +pointer fmd, im1, im2, kernel +real rinner, router, ratio, theta, constant, a1, b1, c1, f1, a2, b2, c2, f2 + +bool clgetb(), fp_equalr() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +int med_mkring() +pointer immap() +real clgetr() +errchk med_ell_gauss, med_mkring, fmd_maxmin, fmd_medring + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allcoate space for the fmedian structure. + call calloc (fmd, LEN_FRMEDIAN_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the ring filter parameters. + rinner = clgetr ("rinner") + router = clgetr ("router") + ratio = clgetr ("ratio") + theta = clgetr ("theta") + + # Get the quantization parameters. + FRMED_Z1(fmd) = clgetr ("zmin") + FRMED_Z2(fmd) = clgetr ("zmax") + FRMED_ZLOW(fmd) = clgetr ("zloreject") + FRMED_ZHIGH(fmd) = clgetr ("zhireject") + FRMED_HMIN(fmd) = clgeti ("hmin") + FRMED_HMAX(fmd) = clgeti ("hmax") + FRMED_UNMAP(fmd) = btoi (clgetb ("unmap")) + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Check kernel parameters. + if (fp_equalr (real(router), 0.0)) + call error (0, "T_FRMEDIAN: Router must be greater than 0.") + if (rinner >= router) + call error (0, "T_FRMEDIAN: Rinner must be less than router.") + if (ratio < 0.0 || ratio > 1.0) + call error (0, "T_FRMEDIAN: Ratio must be between 0 and 1.") + if (theta < 0.0 || theta > 180.0) + call error (0, + "T_FRMEDIAN: Theta must be between 0 and 180 degrees.") + if (fp_equalr (ratio, 0.0) && ! fp_equalr (theta, 0.0) && + ! fp_equalr (theta, 90.0) && ! fp_equalr (theta, 180.0)) + call error (0, + "T_FRMEDIAN: Cannot make 1D ring filter at given theta.") + + # Median filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (verbose) { + call printf ( "Ring rin=%0.1f rout=%0.1f ") + call pargr (rinner) + call pargr (router) + if (ratio < 1.0) { + call printf ("ratio=%0.2f theta=%0.1f ") + call pargr (ratio) + call pargr (theta) + } + call printf ("median filter %s to %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + kernel = NULL + + # Median filter the image. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + call med_ell_gauss (rinner, 0.0, 0.0, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, 0.0, 0.0, a2, b2, c2, f2, + nxk, nyk) + case 2: + call med_ell_gauss (rinner, ratio, theta, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, ratio, theta, a2, b2, c2, f2, + nxk, nyk) + default: + call error (0, + "T_FRMEDIAN: Cannot median filter a greater than 2D image.") + } + + call calloc (kernel, nxk * nyk, TY_SHORT) + FRMED_NRING(fmd) = med_mkring (Mems[kernel], nxk, nyk, + a1, b1, c1, f1, a2, b2, c2, f2) + + # Find input image max and min if necessary. + if (IS_INDEFR(FRMED_Z1(fmd)) || IS_INDEFR(FRMED_Z2(fmd))) + call fmd_maxmin (im1, nxk, nyk, boundary, constant, + FRMED_ZMIN(fmd), FRMED_ZMAX(fmd)) + + if (verbose) { + if (! fp_equalr (FRMED_Z1(fmd), real(FRMED_HMIN(fmd))) && + ! fp_equalr (FRMED_Z2(fmd), real(FRMED_HMAX(fmd)))) { + call printf ( + " Pixels from %g to %g mapped to integers from %d to %d\n") + if (IS_INDEFR(FRMED_Z1(fmd))) + call pargr (FRMED_ZMIN(fmd)) + else + call pargr (FRMED_Z1(fmd)) + if (IS_INDEFR(FRMED_Z2(fmd))) + call pargr (FRMED_ZMAX(fmd)) + else + call pargr (FRMED_Z2(fmd)) + call pargi (FRMED_HMIN(fmd)) + call pargi (FRMED_HMAX(fmd)) + } + if (! IS_INDEFR(FRMED_ZLOW(fmd)) || + ! IS_INDEFR(FRMED_ZHIGH(fmd))) { + call printf ( + " Pixels < %g or > %g excluded from the median filter\n") + call pargr (FRMED_ZLOW(fmd)) + call pargr (FRMED_ZHIGH(fmd)) + } + call flush (STDOUT) + } + + + call fmd_medring (fmd, im1, im2, boundary, constant, + Mems[kernel], nxk, nyk) + + } then { + call eprintf ("Error median filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (kernel != NULL) + call mfree (kernel, TY_SHORT) + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (fmd, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_frmode.x b/pkg/images/imfilter/src/t_frmode.x new file mode 100644 index 00000000..c08baa98 --- /dev/null +++ b/pkg/images/imfilter/src/t_frmode.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "frmode.h" + +# T_FRMODE -- Ring modal filter a list of images in x and y. + +procedure t_frmode() + +bool verbose +int list1, list2, boundary, nxk, nyk +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str +pointer fmd, im1, im2, kernel +real rinner, router, ratio, theta, constant, a1, b1, c1, f1, a2, b2, c2, f2 + +bool clgetb(), fp_equalr() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +int med_mkring() +pointer immap() +real clgetr() +errchk med_ell_gauss, med_mkring, fmd_maxmin, fmd_modring + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allcoate space for the fmode structure. + call calloc (fmd, LEN_FRMODE_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the ring filter parameters. + rinner = clgetr ("rinner") + router = clgetr ("router") + ratio = clgetr ("ratio") + theta = clgetr ("theta") + + # Get the quantization parameters. + FRMOD_Z1(fmd) = clgetr ("zmin") + FRMOD_Z2(fmd) = clgetr ("zmax") + FRMOD_ZLOW(fmd) = clgetr ("zloreject") + FRMOD_ZHIGH(fmd) = clgetr ("zhireject") + FRMOD_HMIN(fmd) = clgeti ("hmin") + FRMOD_HMAX(fmd) = clgeti ("hmax") + FRMOD_UNMAP(fmd) = btoi (clgetb ("unmap")) + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Check kernel parameters. + if (fp_equalr (real(router), 0.0)) + call error (0, "T_FRMODE: Router must be greater than 0.") + if (rinner >= router) + call error (0, "T_FRMODE: Rinner must be less than router.") + if (ratio < 0.0 || ratio > 1.0) + call error (0, "T_FRMODE: Ratio must be between 0 and 1.") + if (theta < 0.0 || theta > 180.0) + call error (0, + "T_FRMODE: Theta must be between 0 and 180 degrees.") + if (fp_equalr (ratio, 0.0) && ! fp_equalr (theta, 0.0) && + ! fp_equalr (theta, 90.0) && ! fp_equalr (theta, 180.0)) + call error (0, + "T_FRMODE: Cannot make 1D ring filter at given theta.") + + # Modal filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (verbose) { + call printf ( "Ring rin=%0.1f rout=%0.1f ") + call pargr (rinner) + call pargr (router) + if (ratio < 1.0) { + call printf ("ratio=%0.2f theta=%0.1f ") + call pargr (ratio) + call pargr (theta) + } + call printf ("modal filter %s to %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + kernel = NULL + + # Modal filter the image. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + call med_ell_gauss (rinner, 0.0, 0.0, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, 0.0, 0.0, a2, b2, c2, f2, + nxk, nyk) + case 2: + call med_ell_gauss (rinner, ratio, theta, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, ratio, theta, a2, b2, c2, f2, + nxk, nyk) + default: + call error (0, + "T_FRMODE: Cannot modal filter a greater than 2D image.") + } + + call calloc (kernel, nxk * nyk, TY_SHORT) + FRMOD_NRING(fmd) = med_mkring (Mems[kernel], nxk, nyk, + a1, b1, c1, f1, a2, b2, c2, f2) + + # Find input image max and min if necessary. + if (IS_INDEFR(FRMOD_Z1(fmd)) || IS_INDEFR(FRMOD_Z2(fmd))) + call fmd_maxmin (im1, nxk, nyk, boundary, constant, + FRMOD_ZMIN(fmd), FRMOD_ZMAX(fmd)) + + if (verbose) { + if (! fp_equalr (FRMOD_Z1(fmd), real(FRMOD_HMIN(fmd))) && + ! fp_equalr (FRMOD_Z2(fmd), real(FRMOD_HMAX(fmd)))) { + call printf ( + " Pixels from %g to %g mapped to integers from %d to %d\n") + if (IS_INDEFR(FRMOD_Z1(fmd))) + call pargr (FRMOD_ZMIN(fmd)) + else + call pargr (FRMOD_Z1(fmd)) + if (IS_INDEFR(FRMOD_Z2(fmd))) + call pargr (FRMOD_ZMAX(fmd)) + else + call pargr (FRMOD_Z2(fmd)) + call pargi (FRMOD_HMIN(fmd)) + call pargi (FRMOD_HMAX(fmd)) + } + if (! IS_INDEFR(FRMOD_ZLOW(fmd)) || + ! IS_INDEFR(FRMOD_ZHIGH(fmd))) { + call printf ( + " Pixels < %g or > %g excluded from the modal filter\n") + call pargr (FRMOD_ZLOW(fmd)) + call pargr (FRMOD_ZHIGH(fmd)) + } + call flush (STDOUT) + } + + + call fmd_modring (fmd, im1, im2, boundary, constant, + Mems[kernel], nxk, nyk) + + } then { + call eprintf ("Error modal filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (kernel != NULL) + call mfree (kernel, TY_SHORT) + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (fmd, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_gauss.x b/pkg/images/imfilter/src/t_gauss.x new file mode 100644 index 00000000..1121b7cb --- /dev/null +++ b/pkg/images/imfilter/src/t_gauss.x @@ -0,0 +1,297 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# T_GAUSS -- Convolve a list of IRAF images with a Gaussian convolution +# kernel. + +procedure t_gauss() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list + +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image + +real sigma # Sigma in x +real ratio # Ratio of sigma in y to x +real theta # Position angle +real nsigma # Extent of Gaussian +int bilinear # Use bilinear kernel approx + +int boundary # Type of boundary extension +real constant # Constant boundary extension + +char str[SZ_LINE], imtemp[SZ_FNAME] +int list1, list2, kbilinear, nxk1, nyk1, nxk2, nyk2, radsym +pointer sp, im1, im2, kernel1, kernel2 +real a1, b1, c1, f1, a2, b2, c2, f2 + +bool clgetb(), fp_equalr() +int imtopen(), imtgetim(), imtlen(), clgwrd(), btoi() +pointer immap() +real clgetr() + +errchk cnv_ell_gauss, cnv_gauss_kernel, cnv_convolve + +begin + # Get task input and output parameters. + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + + # Get the convolution kernel parameters. + sigma = clgetr ("sigma") + ratio = clgetr ("ratio") + theta = clgetr ("theta") + nsigma = clgetr ("nsigma") + bilinear = btoi (clgetb ("bilinear")) + + # Get the image boundary extension parameters. + boundary = clgwrd ("boundary", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + if (boundary == BT_CONSTANT) + constant = clgetr ("constant") + + # Check the input and output image list lengths. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Check kernel parameters. + if (fp_equalr (sigma, 0.0)) + call error (0, "T_GAUSS: Sigma must be greater than 0.") + if (ratio < 0.0 || ratio > 1.0) + call error (0, "T_GAUSS: Ratio must be between 0 and 1.") + if (theta < 0.0 || theta > 180.0) + call error (0, "T_GAUSS: Theta must be between 0 and 180 degrees.") + if (nsigma <= 0.0) + call error (0, "T_GAUSS: Nsigma must be greater than 0.") + if (fp_equalr (ratio, 0.0) && ! fp_equalr (theta, 0.0) && + ! fp_equalr (theta, 90.0) && ! fp_equalr (theta, 180.0)) + call error (0, "T_GAUSS: Cannot make 1D Gaussian at given theta.") + + # Convolve the images in the list the with the Gaussian kernel. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Make the temporary image. + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + # Open the input and output images. + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + kernel1 = NULL + kernel2 = NULL + + # Convolve an image with the Gaussian kernel. + iferr { + + # Calculate the ellipse parameters. + switch (IM_NDIM(im1)) { + + case 1: + kbilinear = NO + radsym = YES + call cnv_ell_gauss (sigma, 0.0, 0.0, nsigma, a1, b1, + c1, f1, nxk1, nyk1) + + case 2: + if (ratio < 1.0) { + + # Determine whether the convolution can be bilinear + # and radially symmetric. + if (fp_equalr (ratio, 0.0)) { + kbilinear = NO + radsym = YES + } else if (fp_equalr (theta, 0.0) || fp_equalr (theta, + 90.0) || fp_equalr (theta, 180.0)) { + kbilinear = bilinear + radsym = YES + } else { + kbilinear = NO + radsym = NO + } + + if (kbilinear == YES) { + if (fp_equalr (theta, 90.0)) { + call cnv_ell_gauss (ratio * sigma, 0.0, 0.0, + nsigma, a1, b1, c1, f1, nxk1, nyk1) + call cnv_ell_gauss (sigma, 0.0, 90.0, + nsigma, a2, b2, c2, f2, nxk2, nyk2) + } else { + call cnv_ell_gauss (sigma, 0.0, 0.0, nsigma, + a1, b1, c1, f1, nxk1, nyk1) + call cnv_ell_gauss (ratio * sigma, 0.0, 90.0, + nsigma, a2, b2, c2, f2, nxk2, nyk2) + } + } else + call cnv_ell_gauss (sigma, ratio, theta, nsigma, + a1, b1, c1, f1, nxk1, nyk1) + + } else { + + kbilinear = bilinear + radsym = YES + + if (kbilinear == YES) { + call cnv_ell_gauss (sigma, 0.0, 0.0, nsigma, a1, + b1, c1, f1, nxk1, nyk1) + call cnv_ell_gauss (sigma, 0.0, 90.0, nsigma, a2, + b2, c2, f2, nxk2, nyk2) + } else + call cnv_ell_gauss (sigma, ratio, theta, nsigma, + a1, b1, c1, f1, nxk1, nyk1) + } + + default: + call error (0, + "T_GAUSS: Cannot convolve a 3D or higher dimensioned image.") + } + + # Compute the kernel. + call smark (sp) + call salloc (kernel1, nxk1 * nyk1, TY_REAL) + call cnv_gauss_kernel (Memr[kernel1], nxk1, nyk1, a1, b1, + c1, f1) + if (kbilinear == YES) { + call salloc (kernel2, nxk2 * nyk2, TY_REAL) + call cnv_gauss_kernel (Memr[kernel2], nxk2, nyk2, a2, b2, + c2, f2) + } + + # Convolve the image. + if (kbilinear == YES) + call cnv_xyconvolve (im1, im2, Memr[kernel1], nxk1, + Memr[kernel2], nyk2, boundary, constant, radsym) + else + call cnv_convolve (im1, im2, Memr[kernel1], nxk1, nyk1, + boundary, constant, radsym) + + } then { + call eprintf ("Error convolving image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (image2) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (image2, imtemp) + } + + if (kernel1 != NULL || kernel2 != NULL) + call sfree (sp) + kernel1 = NULL + kernel2 = NULL + } + + # Close images lists. + call imtclose (list1) + call imtclose (list2) +end + + +# CNV_ELL_GAUSS -- Compute the parameters of the elliptical Gaussian. + +procedure cnv_ell_gauss (sigma, ratio, theta, nsigma, a, b, c, f, nx, ny) + +real sigma # Sigma of Gaussian in x +real ratio # Ratio of half-width in y to x +real theta # Position angle of Gaussian +real nsigma # Limit of convolution +real a, b, c, f # Ellipse parameters +int nx, ny # Dimensions of the kernel + +real sx2, sy2, cost, sint, discrim +bool fp_equalr () + +begin + # Define some constants. + sx2 = sigma ** 2 + sy2 = (ratio * sigma) ** 2 + cost = cos (DEGTORAD (theta)) + sint = sin (DEGTORAD (theta)) + + # Compute the ellipse parameters. + if (fp_equalr (ratio, 0.0)) { + + if (fp_equalr (theta, 0.0) || fp_equalr (theta, 180.)) { + a = 1. / sx2 + b = 0.0 + c = 0.0 + } else if (fp_equalr (theta, 90.0)) { + a = 0.0 + b = 0.0 + c = 1. / sx2 + } else + call error (0, "CNV_GAUSS_KERNEL: Cannot make 1D Gaussian.") + + f = nsigma ** 2 / 2. + nx = 2. * sigma * nsigma * abs (cost) + 1. + ny = 2. * sigma * nsigma * abs (sint) + 1. + + } else { + + a = cost ** 2 / sx2 + sint ** 2 / sy2 + b = 2. * (1.0 / sx2 - 1.0 / sy2) * cost * sint + c = sint ** 2 / sx2 + cost ** 2 / sy2 + discrim = b ** 2 - 4. * a * c + f = nsigma ** 2 / 2. + nx = 2. * sqrt (-8. * c * f / discrim) + 1. + ny = 2. * sqrt (-8. * a * f / discrim) + 1. + } + + # Force the kernel to the next nearest odd integer. + if (mod (nx, 2) == 0) + nx = nx + 1 + if (mod (ny, 2) == 0) + ny = ny + 1 +end + + +# CNV_GAUSS_KERNEL -- Construct the Gaussian kernel using an the elliptical +# Gaussian parameters. + +procedure cnv_gauss_kernel (kernel, nx, ny, a, b, c, f) + +real kernel[nx,ny] # Gaussian kernel +int nx, ny # Dimensions of the kernel +real a, b, c, f # Ellipse parameters + +int i, j, x0, y0, x, y +real norm +bool fp_equalr() + +begin + # Define some constants. + x0 = nx / 2 + 1 + y0 = ny / 2 + 1 + norm = 0.0 + + # Compute the kernel. + do j = 1, ny { + y = j - y0 + do i = 1, nx { + x = i - x0 + kernel[i,j] = 0.5 * (a * x ** 2 + c * y ** 2 + b * x * y) + if (kernel[i,j] <= f) { + kernel[i,j] = exp (-kernel[i,j]) + norm = norm + kernel[i,j] + } else + kernel[i,j] = 0.0 + } + } + + # Normalize the kernel. + if (! fp_equalr (norm, 0.0)) + call adivkr (kernel, norm, kernel, nx * ny) +end diff --git a/pkg/images/imfilter/src/t_gradient.x b/pkg/images/imfilter/src/t_gradient.x new file mode 100644 index 00000000..e66bd65f --- /dev/null +++ b/pkg/images/imfilter/src/t_gradient.x @@ -0,0 +1,245 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define GR_180 1 # Direction of maximum filter response +define GR_0 2 # +define GR_90 3 # +define GR_270 4 # +define GR_135 5 # +define GR_45 6 # +define GR_225 7 # +define GR_315 8 # + +# T_GRADIENT -- Convolve a list of IRAF images with the specified gradient +# filter + +procedure t_gradient() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list + +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image + +int filter # Laplacian filter +int boundary # Type of boundary extension +real constant # Constant boundary extension + +char str[SZ_LINE], imtemp[SZ_FNAME] +int list1, list2, nxk, nyk +pointer sp, im1, im2, kernel + +int imtopen(), imtgetim(), imtlen(), clgwrd() +pointer immap() +real clgetr() + +errchk cnv_convolve + +begin + # Get task parameters. + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + + # Get boundary extension parameters. + filter = clgwrd ("gradient", str, SZ_LINE, + ",180,0,90,270,135,45,225,315,") + boundary = clgwrd ("boundary", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + + # Check list lengths. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, + "The numbers of input and output images are not equal.") + } + + # Convolve the images with gradient kernel. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Make temporary image. + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + # Open images. + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + kernel = NULL + + # Convolve an image with gradient kernel. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + nxk = 3 + nyk = 1 + case 2: + nxk = 3 + nyk = 3 + default: + call error (0, + "T_GRADIENT: The image has more than 2 dimensions.") + } + + # Make the kernel. + call smark (sp) + call salloc (kernel, nxk * nyk, TY_REAL) + call cnv_gradient_kernel (Memr[kernel], nxk, nyk, filter) + + # Gradient filter the image. + call cnv_convolve (im1, im2, Memr[kernel], nxk, nyk, boundary, + constant, NO) + + } then { + call eprintf ("Error convolving image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (image2) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (image2, imtemp) + } + + if (kernel != NULL) + call sfree (sp) + kernel = NULL + } + + # Close images. + call imtclose (list1) + call imtclose (list2) +end + +# CNV_GRADIENT_KERNEL -- Make the gradient kernel. + +procedure cnv_gradient_kernel (kernel, nx, ny, filter) + +real kernel[nx,ny] # Gaussian kernel +int nx, ny # dimensions of the kernel +int filter # which filter + +real norm + +begin + if (ny == 1) { + + switch (filter) { + case GR_0: + kernel[1,1] = -1. / 2. + kernel[2,1] = 0. + kernel[3,1] = 1. / 2. + case GR_180: + kernel[1,1] = 1. / 2. + kernel[2,1] = 0. + kernel[3,1] = -1. / 2. + default: + call error (0, + "CNV_GRADIENT_KERNEL: Cannot compute 2D gradient") + } + + } else { + + switch (filter) { + case GR_0: + norm = 4. + 2. * SQRTOF2 + kernel[1,1] = -1. / norm + kernel[2,1] = 0. + kernel[3,1] = 1. / norm + kernel[1,2] = - SQRTOF2 / norm + kernel[2,2] = 0. + kernel[3,2] = SQRTOF2 / norm + kernel[1,3] = -1. / norm + kernel[2,3] = 0. + kernel[3,3] = 1. / norm + case GR_180: + norm = 4. + 2. * SQRTOF2 + kernel[1,1] = 1. / norm + kernel[2,1] = 0. + kernel[3,1] = -1. / norm + kernel[1,2] = SQRTOF2 / norm + kernel[2,2] = 0. + kernel[3,2] = - SQRTOF2 / norm + kernel[1,3] = 1. / norm + kernel[2,3] = 0. + kernel[3,3] = -1. / norm + case GR_90: + norm = 4. + 2. * SQRTOF2 + kernel[1,1] = -1. / norm + kernel[2,1] = - SQRTOF2 / norm + kernel[3,1] = -1. / norm + kernel[1,2] = 0. + kernel[2,2] = 0. + kernel[3,2] = 0. + kernel[1,3] = 1. / norm + kernel[2,3] = SQRTOF2 / norm + kernel[3,3] = 1. / norm + case GR_270: + norm = 4. + 2. * SQRTOF2 + kernel[1,1] = 1. / norm + kernel[2,1] = SQRTOF2 / norm + kernel[3,1] = 1. / norm + kernel[1,2] = 0. + kernel[2,2] = 0. + kernel[3,2] = 0. + kernel[1,3] = -1. / norm + kernel[2,3] = - SQRTOF2 / norm + kernel[3,3] = -1. / norm + case GR_45: + norm = 2. * SQRTOF2 + 1. + kernel[1,1] = -1. / (2. * SQRTOF2 * norm) + kernel[2,1] = -1. / norm + kernel[3,1] = 0. + kernel[1,2] = -1. / norm + kernel[2,2] = 0. + kernel[3,2] = 1. / norm + kernel[1,3] = 0. + kernel[2,3] = 1. / norm + kernel[3,3] = 1. / (2. * SQRTOF2 * norm) + case GR_225: + norm = 2. * SQRTOF2 + 1. + kernel[1,1] = 1. / (2. * SQRTOF2 * norm) + kernel[2,1] = 1. / norm + kernel[3,1] = 0. + kernel[1,2] = 1. / norm + kernel[2,2] = 0. + kernel[3,2] = -1. / norm + kernel[1,3] = 0. + kernel[2,3] = -1. / norm + kernel[3,3] = -1. / (2. * SQRTOF2 * norm) + case GR_135: + norm = 2. * SQRTOF2 + 1. + kernel[1,1] = 0. + kernel[2,1] = -1. / norm + kernel[3,1] = -1. / (2. * SQRTOF2 * norm) + kernel[1,2] = 1. / norm + kernel[2,2] = 0. + kernel[3,2] = -1. / norm + kernel[1,3] = 1. / (2. * SQRTOF2 * norm) + kernel[2,3] = 1. / norm + kernel[3,3] = 0. + case GR_315: + norm = 2. * SQRTOF2 + 1. + kernel[1,1] = 0. + kernel[2,1] = 1. / norm + kernel[3,1] = 1. / (2. * SQRTOF2 * norm) + kernel[1,2] = -1. / norm + kernel[2,2] = 0. + kernel[3,2] = 1. / norm + kernel[1,3] = -1. / (2. * SQRTOF2 * norm) + kernel[2,3] = -1. / norm + kernel[3,3] = 0. + default: + call error (0, "CNV_GRADIENT_KERNEL: Unknown filter.") + } + } +end diff --git a/pkg/images/imfilter/src/t_laplace.x b/pkg/images/imfilter/src/t_laplace.x new file mode 100644 index 00000000..361118e4 --- /dev/null +++ b/pkg/images/imfilter/src/t_laplace.x @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define LP_XYCENTER 1 # Horizontal and vertical +define LP_DIAG 2 # Diagonal direction +define LP_XYALL 3 # Average of 3 horizontal and + # vertical +define LP_XYDIAG 4 # Unsharp masking kernel + +# T_LAPLACE -- Convolve a list of IRAF images with the Laplacian + +procedure t_laplace() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list + +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image + +int filter # Laplacian filter +int boundary # Type of boundary extension +real constant # Constant boundary extension + +char str[SZ_LINE], imtemp[SZ_FNAME] +int list1, list2, nxk, nyk +pointer sp, im1, im2, kernel + +int imtopen(), imtgetim(), imtlen(), clgwrd() +pointer immap() +real clgetr() + +errchk cnv_convolve + +begin + # Get the task parameters. + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + + # Get the boundary extension parameters. + filter = clgwrd ("laplace", str, SZ_LINE, + ",xycentral,diagonals,xyall,xydiagonals,") + boundary = clgwrd ("boundary", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + + # Check the input and output image list lengths. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Convolve the images with a Laplacian kernel. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + # Make a temporary image. + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + # Open the input and output images. + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + kernel = NULL + + # Do the convolution. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + nxk = 3 + nyk = 1 + case 2: + nxk = 3 + nyk = 3 + default: + call error (0, "T_LAPLACE: Too many image dimensions.") + } + + call smark (sp) + call salloc (kernel, nxk * nyk, TY_REAL) + call cnv_laplace_kernel (Memr[kernel], nxk, nyk, filter) + + call cnv_convolve (im1, im2, Memr[kernel], nxk, nyk, boundary, + constant, YES) + + } then { + call eprintf ("Error convolving image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (image2) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (image2, imtemp) + } + + if (kernel != NULL) + call sfree (sp) + kernel = NULL + } + + # Close the list of images. + call imtclose (list1) + call imtclose (list2) +end + + +# CNV_LAPLACE_KERNEL -- Compute the Laplacian kernel. + +procedure cnv_laplace_kernel (kernel, nx, ny, filter) + +real kernel[nx,ny] # Gaussian kernel +int nx, ny # dimensions of the kernel +int filter # which filter + +begin + if (ny == 1) { + + kernel[1,1] = -1. + kernel[2,1] = 2. + kernel[3,1] = -1. + + } else { + + switch (filter) { + case LP_XYCENTER: + kernel[1,1] = 0. + kernel[2,1] = 1. + kernel[3,1] = 0. + kernel[1,2] = 1. + kernel[2,2] = -4. + kernel[3,2] = 1. + kernel[1,3] = 0. + kernel[2,3] = 1. + kernel[3,3] = 0. + case LP_DIAG: + kernel[1,1] = 1. / SQRTOF2 + kernel[2,1] = 0. + kernel[3,1] = 1. / SQRTOF2 + kernel[1,2] = 0. + kernel[2,2] = -4. / SQRTOF2 + kernel[3,2] = 0. + kernel[1,3] = 1. / SQRTOF2 + kernel[2,3] = 0. + kernel[3,3] = 1. / SQRTOF2 + case LP_XYALL: + kernel[1,1] = 2. / 3. + kernel[2,1] = -1. / 3. + kernel[3,1] = 2. / 3. + kernel[1,2] = -1. / 3. + kernel[2,2] = -4. / 3. + kernel[3,2] = -1. / 3. + kernel[1,3] = 2. / 3. + kernel[2,3] = -1. / 3. + kernel[3,3] = 2. / 3. + case LP_XYDIAG: + kernel[1,1] = 1. / (SQRTOF2 * 2.) + kernel[2,1] = .5 + kernel[3,1] = 1. / (SQRTOF2 * 2.) + kernel[1,2] = .5 + kernel[2,2] = -2. - SQRTOF2 + kernel[3,2] = .5 + kernel[1,3] = 1. / (SQRTOF2 * 2.) + kernel[2,3] = .5 + kernel[3,3] = 1. / (SQRTOF2 * 2.) + default: + call error (0, "CNV_LAPLACE_KERNEL: Unknown filter.") + } + } +end diff --git a/pkg/images/imfilter/src/t_median.x b/pkg/images/imfilter/src/t_median.x new file mode 100644 index 00000000..680ed3be --- /dev/null +++ b/pkg/images/imfilter/src/t_median.x @@ -0,0 +1,126 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "median.h" + +# T_MEDIAN -- Median filter an image in x and y. + +procedure t_median() + +bool verbose +int list1, list2, xwindow, ywindow, boundary +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str, im1, im2, mde +real constant +bool clgetb() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd() +pointer immap() +real clgetr() +errchk mde_medbox + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate the median fitting structure + call calloc (mde, LEN_MEDIAN_STRUCT, TY_STRUCT) + + # Get task parameters + call clgstr ("input", Memc[imtlist1], SZ_LINE) + call clgstr ("output", Memc[imtlist2], SZ_LINE) + + # Get algorithm parameters. + xwindow = clgeti ("xwindow") + ywindow = clgeti ("ywindow") + MED_ZLOW(mde) = clgetr ("zloreject") + if (IS_INDEFR(MED_ZLOW(mde))) + MED_ZLOW(mde) = -MAX_REAL + MED_ZHIGH(mde) = clgetr ("zhireject") + if (IS_INDEFR(MED_ZHIGH(mde))) + MED_ZHIGH(mde) = MAX_REAL + + # Get boundary extension parameters + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Median filter the input images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (mod (xwindow, 2) == 0) + MED_XBOX(mde) = xwindow + 1 + else + MED_XBOX(mde) = xwindow + if (mod (ywindow, 2) == 0) + MED_YBOX(mde) = ywindow + 1 + else + MED_YBOX(mde) = ywindow + + if (verbose) { + call printf ("%dx%d Box median filter %s to %s\n") + call pargi (MED_XBOX(mde)) + call pargi (MED_YBOX(mde)) + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + if (MED_ZLOW(mde) > -MAX_REAL || MED_ZHIGH(mde) < MAX_REAL) { + call printf ( + " Pixels < %g or > %g excluded from the median filter\n") + if (MED_ZLOW(mde) <= -MAX_REAL) + call pargr (INDEFR) + else + call pargr (MED_ZLOW(mde)) + if (MED_ZHIGH(mde) >= MAX_REAL) + call pargr (INDEFR) + else + call pargr (MED_ZHIGH(mde)) + } + call flush (STDOUT) + } + + + # Median filter an image + iferr { + call mde_medbox (mde, im1, im2, boundary, constant) + } then { + call eprintf ("Error median filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (mde, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_mode.x b/pkg/images/imfilter/src/t_mode.x new file mode 100644 index 00000000..fb04614a --- /dev/null +++ b/pkg/images/imfilter/src/t_mode.x @@ -0,0 +1,125 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "mode.h" + +# T_MODE -- Modal filter an image in x and y. + +procedure t_mode() + +bool verbose +int list1, list2, xwindow, ywindow, boundary +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str, im1, im2, mde +real constant +bool clgetb() +int clgeti(), imtopen(), imtgetim(), imtlen(), clgwrd() +pointer immap() +real clgetr() +errchk mde_modbox + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate the mode fitting structure + call calloc (mde, LEN_MODE_STRUCT, TY_STRUCT) + + # Get task parameters + call clgstr ("input", Memc[imtlist1], SZ_LINE) + call clgstr ("output", Memc[imtlist2], SZ_LINE) + + # Get algorithm parameters. + xwindow = clgeti ("xwindow") + ywindow = clgeti ("ywindow") + MOD_ZLOW(mde) = clgetr ("zloreject") + if (IS_INDEFR(MOD_ZLOW(mde))) + MOD_ZLOW(mde) = -MAX_REAL + MOD_ZHIGH(mde) = clgetr ("zhireject") + if (IS_INDEFR(MOD_ZHIGH(mde))) + MOD_ZHIGH(mde) = MAX_REAL + + # Get boundary extension parameters + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Median filter the input images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (mod (xwindow, 2) == 0) + MOD_XBOX(mde) = xwindow + 1 + else + MOD_XBOX(mde) = xwindow + if (mod (ywindow, 2) == 0) + MOD_YBOX(mde) = ywindow + 1 + else + MOD_YBOX(mde) = ywindow + + if (verbose) { + call printf ("%dx%d Box modal filter %s to %s\n") + call pargi (MOD_XBOX(mde)) + call pargi (MOD_YBOX(mde)) + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + if (MOD_ZLOW(mde) > -MAX_REAL || MOD_ZHIGH(mde) < MAX_REAL) { + call printf ( + " Pixels < %g or > %g excluded from the modal filter\n") + if (MOD_ZLOW(mde) <= -MAX_REAL) + call pargr (INDEFR) + else + call pargr (MOD_ZLOW(mde)) + if (MOD_ZHIGH(mde) >= MAX_REAL) + call pargr (INDEFR) + else + call pargr (MOD_ZHIGH(mde)) + } + call flush (STDOUT) + } + + # Median filter an image + iferr { + call mde_modbox (mde, im1, im2, boundary, constant) + } then { + call eprintf ("Error modal filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (mde, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_rmedian.x b/pkg/images/imfilter/src/t_rmedian.x new file mode 100644 index 00000000..e42cc513 --- /dev/null +++ b/pkg/images/imfilter/src/t_rmedian.x @@ -0,0 +1,179 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "rmedian.h" + +# T_RMEDIAN -- Ring median filter a list of images in x and y. + +procedure t_rmedian() + +bool verbose +int list1, list2, boundary, nxk, nyk +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str +pointer med, im1, im2, kernel +real rinner, router, ratio, theta, constant, a1, b1, c1, f1, a2, b2, c2, f2 + +bool clgetb(), fp_equalr() +int imtopen(), imtgetim(), imtlen(), clgwrd() +int med_mkring() +pointer immap() +real clgetr() +errchk med_ell_gauss, med_mkring, med_medring + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allcoate space for the rmedian structure. + call calloc (med, LEN_RMEDIAN_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the ring filter parameters. + rinner = clgetr ("rinner") + router = clgetr ("router") + ratio = clgetr ("ratio") + theta = clgetr ("theta") + + # Get the rejection parameters. + RMED_ZLOW(med) = clgetr ("zloreject") + if (IS_INDEFR(RMED_ZLOW(med))) + RMED_ZLOW(med) = -MAX_REAL + RMED_ZHIGH(med) = clgetr ("zhireject") + if (IS_INDEFR(RMED_ZHIGH(med))) + RMED_ZHIGH(med) = MAX_REAL + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Check kernel parameters. + if (fp_equalr (real(router), 0.0)) + call error (0, "T_RMEDIAN: Router must be greater than 0.") + if (rinner >= router) + call error (0, "T_RMEDIAN: Rinner must be less than router.") + if (ratio < 0.0 || ratio > 1.0) + call error (0, "T_RMEDIAN: Ratio must be between 0 and 1.") + if (theta < 0.0 || theta > 180.0) + call error (0, + "T_RMEDIAN: Theta must be between 0 and 180 degrees.") + if (fp_equalr (ratio, 0.0) && ! fp_equalr (theta, 0.0) && + ! fp_equalr (theta, 90.0) && ! fp_equalr (theta, 180.0)) + call error (0, + "T_RMEDIAN: Cannot make 1D ring filter at given theta.") + + # Median filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (verbose) { + call printf ( "Ring rin=%0.1f rout=%0.1f ") + call pargr (rinner) + call pargr (router) + if (ratio < 1.0) { + call printf ("ratio=%0.2f theta=%0.1f ") + call pargr (ratio) + call pargr (theta) + } + call printf ("median filter %s to %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + kernel = NULL + + # Median filter the image. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + call med_ell_gauss (rinner, 0.0, 0.0, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, 0.0, 0.0, a2, b2, c2, f2, + nxk, nyk) + case 2: + call med_ell_gauss (rinner, ratio, theta, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, ratio, theta, a2, b2, c2, f2, + nxk, nyk) + default: + call error (0, + "T_RMEDIAN: Cannot median filter a greater than 2D image.") + } + + call calloc (kernel, nxk * nyk, TY_SHORT) + RMED_NRING(med) = med_mkring (Mems[kernel], nxk, nyk, + a1, b1, c1, f1, a2, b2, c2, f2) + + if (verbose) { + if (RMED_ZLOW(med) > -MAX_REAL || RMED_ZHIGH(med) < + MAX_REAL) { + call printf ( + " Pixels < %g or > %g excluded from the median filter\n") + if (RMED_ZLOW(med) <= -MAX_REAL) + call pargr (INDEFR) + else + call pargr (RMED_ZLOW(med)) + if (RMED_ZHIGH(med) >= MAX_REAL) + call pargr (INDEFR) + else + call pargr (RMED_ZHIGH(med)) + } + call flush (STDOUT) + } + + call med_medring (med, im1, im2, boundary, constant, + Mems[kernel], nxk, nyk) + + } then { + call eprintf ("Error median filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (kernel != NULL) + call mfree (kernel, TY_SHORT) + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (med, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_rmode.x b/pkg/images/imfilter/src/t_rmode.x new file mode 100644 index 00000000..2e79f3d5 --- /dev/null +++ b/pkg/images/imfilter/src/t_rmode.x @@ -0,0 +1,179 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "rmode.h" + +# T_RMODE -- Ring modak filter a list of images in x and y. + +procedure t_rmode() + +bool verbose +int list1, list2, boundary, nxk, nyk +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, str +pointer med, im1, im2, kernel +real rinner, router, ratio, theta, constant, a1, b1, c1, f1, a2, b2, c2, f2 + +bool fp_equalr(), clgetb() +int imtopen(), imtgetim(), imtlen(), clgwrd() +int med_mkring() +pointer immap() +real clgetr() +errchk med_ell_gauss, med_mkring, med_modring + +begin + # Allocate some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allcoate space for the rmode structure. + call calloc (med, LEN_RMODE_STRUCT, TY_STRUCT) + + # Get the task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the ring filter parameters. + rinner = clgetr ("rinner") + router = clgetr ("router") + ratio = clgetr ("ratio") + theta = clgetr ("theta") + + # Get the rejection parameters. + RMOD_ZLOW(med) = clgetr ("zloreject") + if (IS_INDEFR(RMOD_ZLOW(med))) + RMOD_ZLOW(med) = -MAX_REAL + RMOD_ZHIGH(med) = clgetr ("zhireject") + if (IS_INDEFR(RMOD_ZHIGH(med))) + RMOD_ZHIGH(med) = MAX_REAL + + # Get the boundary extension parameters. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Check kernel parameters. + if (fp_equalr (real(router), 0.0)) + call error (0, "T_RMODE: Router must be greater than 0.") + if (rinner >= router) + call error (0, "T_RMODE: Rinner must be less than router.") + if (ratio < 0.0 || ratio > 1.0) + call error (0, "T_RMODE: Ratio must be between 0 and 1.") + if (theta < 0.0 || theta > 180.0) + call error (0, + "T_RMODE: Theta must be between 0 and 180 degrees.") + if (fp_equalr (ratio, 0.0) && ! fp_equalr (theta, 0.0) && + ! fp_equalr (theta, 90.0) && ! fp_equalr (theta, 180.0)) + call error (0, + "T_RMODE: Cannot make 1D ring filter at given theta.") + + # Median filter each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + kernel = NULL + + if (verbose) { + call printf ( "Ring rin=%0.1f rout=%0.1f ") + call pargr (rinner) + call pargr (router) + if (ratio < 1.0) { + call printf ("ratio=%0.2f theta=%0.1f ") + call pargr (ratio) + call pargr (theta) + } + call printf ("modal filter %s to %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + call flush (STDOUT) + } + + # Modal filter the image. + iferr { + + switch (IM_NDIM(im1)) { + case 1: + call med_ell_gauss (rinner, 0.0, 0.0, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, 0.0, 0.0, a2, b2, c2, f2, + nxk, nyk) + case 2: + call med_ell_gauss (rinner, ratio, theta, a1, b1, c1, f1, + nxk, nyk) + call med_ell_gauss (router, ratio, theta, a2, b2, c2, f2, + nxk, nyk) + default: + call error (0, + "T_RMODE: Cannot modal filter a greater than 2D image.") + } + + call calloc (kernel, nxk * nyk, TY_SHORT) + RMOD_NRING(med) = med_mkring (Mems[kernel], nxk, nyk, + a1, b1, c1, f1, a2, b2, c2, f2) + + if (verbose) { + if (RMOD_ZLOW(med) > -MAX_REAL || RMOD_ZHIGH(med) < + MAX_REAL) { + call printf ( + " Pixels < %g or > %g excluded from the modal filter\n") + if (RMOD_ZLOW(med) <= -MAX_REAL) + call pargr (INDEFR) + else + call pargr (RMOD_ZLOW(med)) + if (RMOD_ZHIGH(med) >= MAX_REAL) + call pargr (INDEFR) + else + call pargr (RMOD_ZHIGH(med)) + } + call flush (STDOUT) + } + + call med_modring (med, im1, im2, boundary, constant, + Mems[kernel], nxk, nyk) + + } then { + call eprintf ("Error modal filtering image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im1) + call imunmap (im2) + call imdelete (Memc[image2]) + } else { + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (kernel != NULL) + call mfree (kernel, TY_SHORT) + } + + call imtclose (list1) + call imtclose (list2) + + call mfree (med, TY_STRUCT) + + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/t_runmed.x b/pkg/images/imfilter/src/t_runmed.x new file mode 100644 index 00000000..f62416c4 --- /dev/null +++ b/pkg/images/imfilter/src/t_runmed.x @@ -0,0 +1,62 @@ +# T_RUNMED -- Apply running median to a list of input images. + +procedure t_runmed () + +pointer input # List of input images +pointer output # List of output images +int window # Filter window +pointer masks # List of output masks +pointer inmaskkey # Input mask keyword +pointer outmaskkey # Output mask keyword +pointer outtype # Output type +bool exclude # Exclude input image? +real nclip # Clipping factor +int navg # Number of values to average +pointer scale # Scale specification +bool normscale # Normalize the scales to the first input? +bool outscale # Scale the output? +real blank # Blank values +pointer storetype # Storage type +bool verbose # Verbose? + +pointer sp + +int clgeti() +bool clgetb() +real clgetr() +pointer imtopenp() + +begin + call smark (sp) + call salloc (inmaskkey, SZ_FNAME, TY_CHAR) + call salloc (outmaskkey, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_FNAME, TY_CHAR) + call salloc (scale, SZ_FNAME, TY_CHAR) + call salloc (storetype, SZ_FNAME, TY_CHAR) + + input = imtopenp ("input") + output = imtopenp ("output") + window = clgeti ("window") + masks = imtopenp ("masks") + call clgstr ("inmaskkey", Memc[inmaskkey], SZ_FNAME) + call clgstr ("outmaskkey", Memc[outmaskkey], SZ_FNAME) + call clgstr ("outtype", Memc[outtype], SZ_FNAME) + exclude = clgetb ("exclude") + nclip = clgetr ("nclip") + navg = clgeti ("navg") + call clgstr ("scale", Memc[scale], SZ_FNAME) + blank = clgetr ("blank") + normscale = clgetb ("normscale") + outscale = clgetb ("outscale") + call clgstr ("storetype", Memc[storetype], SZ_FNAME) + verbose = clgetb ("verbose") + + call runmed (input, output, window, masks, Memc[inmaskkey], + Memc[outmaskkey], Memc[outtype], exclude, nclip, navg, Memc[scale], + normscale, outscale, blank, Memc[storetype], verbose) + + call imtclose (masks) + call imtclose (output) + call imtclose (input) + call sfree (sp) +end diff --git a/pkg/images/imfilter/src/xyconvolve.x b/pkg/images/imfilter/src/xyconvolve.x new file mode 100644 index 00000000..053aeb5a --- /dev/null +++ b/pkg/images/imfilter/src/xyconvolve.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# CNV_XYCONVOLVE -- Convolve an image with a kernel that is separable in x +# and y. The kernel dimensions may be any size. + +procedure cnv_xyconvolve (im1, im2, xkernel, nxk, ykernel, nyk, boundary, + constant, radsym) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +real xkernel[ARB] # the convolution kernel in x +int nxk # dimensions of the kernel in x +real ykernel[ARB] # the convolution kernel in x +int nyk # dimensions of the kernel in y +int boundary # type of boundary extension +real constant # constant for constant boundary extension +int radsym # does the kernel have radial symmetry + +int i, ncols, nlines, col1, col2, nincols, inline, outline, tempi +pointer sp, lineptrs, imbuf, inbuf, linebuf, outbuf, bufptr, bufptr1, bufptr2 +pointer imgs2r(), impl2r() +errchk imgs2r, impl2r + +begin + # Allocate working space. + call smark (sp) + call salloc (lineptrs, nyk, TY_INT) + + # Set the input image boundary conditions. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2 + 1, nyk / 2 + 1)) + if (boundary == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Compute the number of columns and lines in the output image + # and allocate some buffer space. + ncols = IM_LEN(im2,1) + if (IM_NDIM(im2) == 1) + nlines = 1 + else + nlines = IM_LEN(im2,2) + call calloc (inbuf, ncols * nyk , TY_REAL) + call salloc (linebuf, ncols, TY_REAL) + + # Set the input image column limits and allocate the data buffer. + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1,1) + nxk / 2 + nincols = col2 - col1 + 1 + + # Initialise the line buffers. + inline = 1 - nyk / 2 + do i = 1 , nyk { + Memi[lineptrs+i-1] = i + imbuf = imgs2r (im1, col1, col2, inline, inline) + if (radsym == YES) + call cnv_radcnvr (Memr[imbuf], Memr[inbuf+(i-1)*ncols], ncols, + xkernel, nxk) + else + call acnvr (Memr[imbuf], Memr[inbuf+(i-1)*ncols], ncols, + xkernel, nxk) + inline = inline + 1 + } + + # Generate the output image line by line. + do outline = 1, nlines { + + # Get the output image line. + outbuf = impl2r (im2, outline) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Generate the output image line. + call aclrr (Memr[outbuf], ncols) + if (radsym == YES) { + do i = 1, nyk /2 { + bufptr1 = inbuf + (Memi[lineptrs+i-1] - 1) * ncols + bufptr2 = inbuf + (Memi[lineptrs+nyk-i] - 1) * ncols + call aaddr (Memr[bufptr1], Memr[bufptr2], Memr[linebuf], + ncols ) + call cnv_awsum1 (Memr[outbuf], Memr[linebuf], Memr[outbuf], + ncols, ykernel[i]) + } + bufptr = inbuf + (Memi[lineptrs+nyk/2] - 1) * ncols + if (mod (nyk, 2) == 1) + call cnv_awsum1 (Memr[outbuf], Memr[bufptr], Memr[outbuf], + ncols, ykernel[nyk/2+1]) + } else { + do i = 1, nyk { + bufptr = inbuf + (Memi[lineptrs+i-1] - 1) * ncols + call cnv_awsum1 (Memr[outbuf], Memr[bufptr], Memr[outbuf], + ncols, ykernel[i]) + } + } + + # Scroll the input buffer indices. + tempi = Memi[lineptrs] + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + Memi[lineptrs+nyk-1] = tempi + + # Read in the new input image line. + imbuf = imgs2r (im1, col1, col2, inline, inline) + + # Do the 1D convolution and add the vector into the input buffer. + bufptr = inbuf + (Memi[lineptrs+nyk-1] - 1) * ncols + call aclrr (Memr[bufptr], ncols) + if (radsym == YES) + call cnv_radcnvr (Memr[imbuf], Memr[bufptr], ncols, xkernel, + nxk) + else + call acnvr (Memr[imbuf], Memr[bufptr], ncols, xkernel, nxk) + + # Increment the input image line pointer. + inline = inline + 1 + } + + # Free the buffer pointers. + call mfree (inbuf, TY_REAL) + call sfree (sp) +end diff --git a/pkg/images/imfit/Revisions b/pkg/images/imfit/Revisions new file mode 100644 index 00000000..7ff95abd --- /dev/null +++ b/pkg/images/imfit/Revisions @@ -0,0 +1,2025 @@ +.help revisions Jan97 images.imfit +.nf +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/imfit/doc/fit1d.hlp b/pkg/images/imfit/doc/fit1d.hlp new file mode 100644 index 00000000..5b49f45f --- /dev/null +++ b/pkg/images/imfit/doc/fit1d.hlp @@ -0,0 +1,177 @@ +.help fit1d Jul85 images.imfit +.ih +NAME +fit1d -- fit a function to image lines +.ih +USAGE +.nf +fit1d input output type +.fi +.ih +PARAMETERS +.ls input +Images to be fit. The images may contain image sections. Only the region +covered by the section will be modified in the output image. +.le +.ls output +Output images to be created or modified. The number of output images +must match the number of input images. If an output image does not exist +it is first created and initialized to zero for fit types "fit" and +"difference" and to one for fit type "ratio". +.le +.ls type +Type of output. The choices are: +.ls fit +An image created from the function fits to the image lines. +.le +.ls difference +The difference between the image and the fit (i.e. residuals). +.le +.ls ratio +The ratio of the image and fit. +.le +.le +.ls bpm = "" +List of bad pixel masks. This may be a null string to not use a +bad pixel mask, a single mask that applies to all input images, or +a matching list. The value may also be ! to specify a keyword whose +value is the mask to use. +.le +.ls axis = 1 +Axis along which the one dimensional fitting is done. Axis 1 corresponds +to fitting the image lines and axis 2 corresponds to fitting the columns. +.le +.ls interactive = yes +If \fBinteractive\fR is set to yes, a plot of the fit is drawn and the +cursor is available for interactively examining and adjusting the fit. +.le +.ls sample = "*" +Lines or columns to be used in the fits. +.le +.ls naverage = 1 +Number of sample points to combined to create a fitting point. +A positive value specifies an average and a negative value specifies +a median. +.le +.ls function = spline3 +Function to be fit to the image lines or columns. The functions are +"legendre" (legendre polynomial), "chebyshev" (chebyshev polynomial), +"spline1" (linear spline), and "spline3" (cubic spline). The functions +may be abbreviated. +.le +.ls order = 1 +The order of the polynomials or the number of spline pieces. +.le +.ls low_reject = 0., high_reject = 0. +Rejection limits below and above the fit in units of the residual sigma. +.le +.ls niterate = 1 +Number of rejection iterations. +.le +.ls grow = 0. +When a pixel is rejected, pixels within this distance of the rejected pixel +are also rejected. +.le +.ls graphics = "stdgraph" +Graphics output device for interactive graphics. +.le +.ls cursor = "stdgcur" +Graphics cursor input. +.le +.ih +DESCRIPTION +A one dimensional function is fit to each line or column of the input images. +The function may be a legendre polynomial, chebyshev polynomial, +linear spline, or cubic spline of a given order or number of spline pieces. +The output image is of pixel type real and is formed from the fitted +function values, the difference or residuals of the fit (pixel value - +fitted value), or the ratio between the pixel values and the fitted values. + +The output image may exist in which case a section in the input image is +applied to the output image. Thus, a section on the input image causes only +that part of the output image to be changed. If the output image does not +exist it is first created with a size given by the full (without a section) +input image and initialized to zero for fit and difference output types +and one for ratio output types. + +A bad pixel mask may be specified to exclude data from the fitting. Any +non-zero value in the mask is excluded. It appears in the interactive +fitting in the same way as manually deleted points. The mask is matched to +the input image(s) as described by \fBpmmatch\fR. The default is matching +in physical coordinates. + +The points fit are determined by selecting a sample of lines or columns +specified by the parameter \fIsample\fR and taking either the average or +median of the number of points specified by the parameter \fInaverage\fR. +The type of averaging is selected by the sign of the parameter and the number +of points is selected by the absolute value of the parameter. +The sample points are specified relative to any image sections. + +If \fIlow_reject\fR and/or \fIhigh_reject\fR are greater than zero the sigma +of the residuals between the fitted points and the fitted function is computed +and those points whose residuals are less than \fI-low_reject\fR * sigma +and greater than \fIhigh_reject\fR * sigma are excluded from the fit. +Points within a distance of \fIgrow\fR pixels of a rejected pixel are also +excluded from the fit. The function is then refit without the rejected points. +This rejection procedure may be iterated a number of times given by the +parameter \fIniterate\fR. + +The fitting parameters (\fIsample, naverage, function, order, low_reject, +high_reject, niterate, grow\fR) +may be adjusted interactively if the parameter \fIinteractive\fR is yes. +Lines or columns from the image are selected to be fit with the \fBicfit\fR +package. A single column or line may be chosen or a blank-separated range +may be averaged. Note that the averaging applies only to the graphed +data used to set the fitting parameters. The actual image lines and columns +are fit individually. The interactive cursor mode commands for this package +are described in a separate help entry under "icfit". Line 1 is automatically +selected for one dimensional images and any number of lines or columns may be +selected for two dimensional images. Note that the lines or columns are +relative to the input image section; for example line 1 is the first line of +the image section and not the first line of the image. When an end-of-file or +no line(s) or column(s) are given then the last selected fitting parameters +are used on each line or column of the image. This step is repeated for +each image in the input list. +.ih +EXAMPLES +1. To create a smoothed version of an image by fitting the image lines: + + cl> fit1d image fitimage fit + +If the interactive flag is set and the image is two dimensional then a prompt +for an image line is printed: + + image: Fit line = 100 200 + +The selected lines are averaged, graphed, and the interactive options for +setting and fitting the line are used. Exiting with 'q' or return prompts for +another line if the image is two dimensional. When the fitting parameters +are suitably set then respond with end-of-file or return to fit all the lines +of the image and create the output image. + +2. To subtract a linear function fit to columns 10 to 20 and 80 to 100 from +columns 10 to 100 and to subtract another linear function fit to lines +110 to 120 and 180 to 200 from columns 110 to 200: + +.nf + cl> fit1d image1[10:100,*] output diff axis=2 sample="1:11,71:91" + cl> fit1d image1[110:200,*] output diff axis=2 sample="1:11,71:91" +.fi + +Pixels outside columns 10 to 100 and 110 to 200 are not affected. Note that the +sample points are specified relative to the image sections. The script +\fBbackground\fR is available in other packages for doing background +subtractions. + +3. To determine a small scale response image: + + cl> fit1d image1 flat ratio + +The task \fBimred.generic.flat1d\fR is available for making flat field images +by this method with the addition of an extra parameter to limit the data values +for which the ratio is computed. +.ih +SEE ALSO +imred.generic.background, imred.generic.flat1d +xtools.icfit, lineclean, imsurfit +.endhelp diff --git a/pkg/images/imfit/doc/imsurfit.hlp b/pkg/images/imfit/doc/imsurfit.hlp new file mode 100644 index 00000000..0aa46a97 --- /dev/null +++ b/pkg/images/imfit/doc/imsurfit.hlp @@ -0,0 +1,226 @@ +.help imsurfit Feb88 images.imfit +.ih +NAME +imsurfit -- fit a surface function to an image +.ih +USAGE +imsurfit input, output, xorder, yorder +.ih +PARAMETERS +.ls input +List of images to be fit. +.le +.ls output +Output image(s) of \fItype_output\fR. +.le +.ls xorder +The order in x of the polynomials (1 = constant) or the number of polynomial +pieces for the bicubic spline. +.le +.ls yorder +The order in y of the polynomials (1 = constant) or the number of polynomial +pieces for the bicubic spline. +.le +.ls cross_terms = yes +Cross terms for the polynomials. For example, if \fIxorder\fR = 2 and +\fIyorder\fR = 2 +then a function of the form z = a + b * x + c * y + d * x * y will be fit. +.le +.ls function = "leg" +Functional for of surface to be fit to the image. The available functions +(with minimum match abbreviation) are: +.ls legendre +.le +.ls chebyshev +.le +.ls spline3 +.le +.ls spline1 +.le +.le +.ls type_output = "fit" +The type of output image. The allowed types (with minimum match abbreviation) +are: +.ls clean +The input image with deviant pixels in the good regions replaced by the +fitted value. +.le +.ls fit +An image created from the surface fits to the image. +.le +.ls residual +The difference of the input image and the fitted image. +.le +.ls response +The ratio of the input image to the fitted image. +All fitted (denominator) pixels below \fIdiv_min\fR are given a value of 1. +.le +.le +.ls xmedian = 1, ymedian = 1 +The x and y dimensions of the box used for median processing. +If \fIxmedian\fR > 1 or \fIymedian\fR is > 1, +then the median is calculated for each box and used in the surface +fit instead of the individual pixels. +.le +.ls median_percent = 50. +If the number of pixels in the median box is less than \fImedian_percent\fR * +\fIxmedian\fR * \fIymedian\fR the box will be omitted from the fit. +.le +.ls upper = 0., lower = 0. +The number of sigma limits for pixel rejection. If \fIupper\fR > 0. or +\fIlower\fR > 0. and median processing is turned off, +pixel rejection is enabled. +.le +.ls ngrow = 0 +The radius in pixels for region growing. +Pixels within a distance of \fIngrow\fR pixels of +a rejected pixel are also rejected. +.le +.ls niter = 0 +The maximum number of iterations in the rejection cycle. +Rejection will be terminated if the number of rejected pixels is zero +or the number of iterations equals \fIniter\fR. +.le +.ls regions = "all" +The available options (with minimum match abbreviation) are: +.ls all +All points in the image are fit. +.le +.ls rows +The fit is performed on the image rows specified by \fIrows\fR. +.le +.ls columns +The fit is performed on the image columns specified by \fIcolumns\fR. +.le +.ls border +The fit is performed on a border around the image whose width is specified +by \fIborder\fR. +.le +.ls sections +The fit is performed on image sections listed in the file specified +by \fIsections\fR. +.le +.ls circle +The fit is performed on a circular region whose parameters are specified by +\fIcircle\fR. +.le +.ls invcircle +The fit is performed on a region exterior to the circular region whose +parameters are specified by \fIcircle\fR. +.le +.le +.ls rows = "*" +When \fIregion_type\fR = 'rows', the string parameter \fIrows\fR specifies +the rows to be fit. +.le +.ls columns = "*" +When \fIregion_type\fR = 'columns', the string parameter \fIcolumns\fR +specifies the columns to be fit. +.le +.ls border = "50" +When \fIregion_type\fR = 'border', the +string parameter \fIborder\fR specifies the width of the border to be fit. +.le +.ls sections = "" +When \fIregion_type\fR = 'sections', the +string parameter \fIsections\fR is the name of the file containing the list of +image sections to be fit, where \fISections\fR may be the standard +input (STDIN). +The sections must be listed one per line in the following form: x1 x2 y1 y2. +.le +.ls circle = "" +The string parameter \fIcircle\fR lists the parameter needed to specify +the circle in the following format: xcenter ycenter radius. The three +parameters must be integers. +.le +.ls div_min = INDEF +When \fItype_output\fR = 'response' all divisions in which the fitted value +is below \fIdiv_min\fR are set to the value 1. +.le +.ih +DESCRIPTION +A surface is fit to selected portions of the input image. +The user may elect to fit the whole image, \fIregion_type\fR = 'all', +selected rows, \fIregion_type\fR = 'rows', selected columns, +\fIregion_type\fR = 'columns', a +border around the image, \fIregion_type\fR = 'border' or image sections, +\fIregion_type\fR = 'sections'. If the sections option is enabled the user +must supply the name of the file containing a list of sections, +\fIsections\fR = 'list', or enter them from the standard input. In either case +the sections must be listed one per line in the following form: x1 x2 y1 y2. + +The parameter \fIsurface_type\fR may be a +"legendre" polynomial, "chebyshev" polynomial, +a cubic spline ("spline3") or a linear spline ("spline1"). +The order of the polynomials is selected in both x and y. +Cross terms for the polynomial surfaces are optional. +For the cubic spline the parameters \fIxorder\fR and \fIyorder\fR specify +the number of polynomial pieces to be fit to the surface in +each direction. + +The output image may be the fitted image, the difference between the +input and the fitted image, the ratio of the input to the fitted image +or the input image with deviant pixels in the fitted regions replaced +with the fitted values, according to whether \fItype_output\fR = +'fit', 'residual', +'response' or 'clean'. If \fItype_output\fR = 'response' then pixels in the +fitted image with values < \fIdiv_min\fR are replaced by 1. +If \fItype_output\fR = +'clean' then at least one of \fIupper\fR or \fIlower\fR must be > 0. + +Pixel rejection is enabled if median processing is turned off, +\fIniter\fR > 0, +and at least one of the parameters \fIupper\fR and \fIlower\fR is > 0. +Region growing +can be turned on by setting \fIngrow\fR > 0, in which case all pixels within +a radius ngrow of a deviant pixel will be rejected. + +.ih +EXAMPLES +1. To create a smoothed version of an image: + +.nf + cl> imsurfit m74 m74smooth 5 10 function=spline3 +.fi + +2. To create a smoothed version of an image using median processing: + +.nf + cl> imsurfit m74 m74med 5 10 function=spline3 \ + >>> xmed=5 ymed=5 +.fi + +3. To subtract a constant background from an image: + +.nf + cl> imsurfit abell30 abell30bck 1 1 function=leg \ + >>> type=resid +.fi + +4. To make a ratio image using signals above 1000 units: + +.nf + cl> imsurfit n7006 n7006ratio 20 20 function=spline3 \ + >>> type=response div_min=1000 +.fi + +.ih +TIMINGS +Fitting and subtracting a constant from a 512 by 512 IRAF image requires +~35 cpu seconds. Approximately 130 cpu seconds are required to fit a +second degree polynomial in x and y (including cross-terms) to a +100 pixel wide border around a 512 by +512 IRAF image, and to subtract the fitted image from the input image. +To produce a smooth 512 by 512 IRAF image using a 10 by 10 bicubic spline +requires ~300 cpu seconds. Timings refer to a VAX 11/750 + fpa. + +.ih +NOTES +The surface fitting code uses the IRAF SURFIT math routines, +which have been optimized for image fitting . +The routines which fit selected portions +of the image, perform pixel rejection and region growing, and create and +maintain a list of rejected pixels utilize the ranges and pixlist packages +of routines currently maintained in the images directory. These will be +replaced by more general ranges and image masking routines in the future. +.endhelp diff --git a/pkg/images/imfit/doc/lineclean.hlp b/pkg/images/imfit/doc/lineclean.hlp new file mode 100644 index 00000000..9ce2b95f --- /dev/null +++ b/pkg/images/imfit/doc/lineclean.hlp @@ -0,0 +1,129 @@ +.help lineclean May85 images.imfit +.ih +NAME +lineclean -- replace deviant pixels in image lines +.ih +USAGE +.nf +lineclean input output +.fi +.ih +PARAMETERS +.ls input +Input images to be cleaned. +.le +.ls output +Output cleaned images. The number of output images must be the same as the +number of input images. +.le +.ls sample = "*" +Columns to be used in fitting the cleaning function. +.le +.ls naverage = 1 +Number of sample points to combined to create a fitting point. +A positive value specifies an average and a negative value specifies +a median. +.le +.ls function = spline3 +Cleaning function to be fit to the image lines. The functions are: +.ls legendre +Legendre polynomial of the specified order. +.le +.ls chebyshev +Chebyshev polynomial of the specified order. +.le +.ls spline1 +Linear spline of the specified number of pieces. +.le +.ls spline3 +Cubic spline of the specified number of pieces. +.le +.le +.ls order = 1 +The order of the polynomials or the number of spline pieces. +.le +.ls low_reject = 2.5, high_reject = 2.5 +Rejection limits below and above the fit in units of the residual sigma. +.le +.ls niterate = 1 +Number of rejection iterations. +.le +.ls grow = 1. +When a pixel is rejected, pixels within this distance of the rejected pixel +are also rejected. +.le +.ls graphics = "stdgraph" +Graphics output device for interactive graphics. +.le +.ls cursor = "stdgcur" +Graphics cursor input. +.le +.ih +DESCRIPTION +A one dimensional function is fit to each line of the input images. +The function may be a legendre polynomial, chebyshev polynomial, +linear spline, or cubic spline of a given order or number of spline pieces. +If \fIlow_reject\fR and/or \fIhigh_reject\fR are greater than zero the sigma +of the residuals between the fitted points and the fitted function is computed +and those points whose residuals are less than \fI-low_reject\fR * sigma +and greater than \fIhigh_reject\fR * sigma are excluded from the fit. +Points within a distance of \fIgrow\fR pixels of a rejected pixel are also +excluded from the fit. The function is then refit without the rejected points. +This rejection procedure may be iterated a number of times given by the +parameter \fIniterate\fR. Finally, the +rejected points in the input image are replaced by the fitted values +to create the output image lines. + +The output image may exist in which case a section in the input image is +applied to the output image. Thus, a section on the input image causes only +that part of the output image to be cleaned. If the output image does not +exist it is first created by making a copy of the full (without a section) +input image. + +The points fit are determined by selecting a sample of columns specified by +the parameter \fIsample\fR and taking either the average or median of +the number of points specified by the parameter \fInaverage\fR. +The type of averaging is selected by the sign of the parameter and the number +of points is selected by the absolute value of the parameter. +The sample points are specified relative to any image section. + +The fitting parameters (\fIsample, naverage, function, order, low_reject, +high_reject, niterate, grow\fR) +may be adjusted interactively if the parameter \fIinteractive\fR is yes. +Lines from the image are selected to be fit with the \fBicfit\fR package. +For images of greater than two dimensions sets of numbers giving the +2nd, 3rd, etc. coordinates are entered. +The image lines are specified relative to any image section. +When an end-of-file or no line is given then the last selected fitting +parameters are used on each line of the image. This step is repeated for +each image in the input list. The interactive options are described +in the help information \fBicfit\fR. +.ih +EXAMPLES +1. To clean pixels deviating by more than 2.5 sigma: + + cl> lineclean image cleanimage + +If the interactive flag is set then a prompt for an image line is +printed: + + image: Fit line = 100 + +For a one or two dimensional image the line number is entered (1 for a one +dimensional image). For a three dimensional image two numbers are entered. +For example: + + image: Fit line = 10 2 + +for line 10 of the second image plane. + +The selected line is graphed and the interactive options for setting and +fitting the line are used. Data points marked with diamonds indicate +points to be replaced by the fitted value. Exiting with 'q' or return +prompts for another line. When the fitting parameters are suitably set +then respond with end-of-file or return to fit all the lines of the image +and create the output image. +.ih +SEE ALSO +fit1d, xtools.icfit, imsurfit +.endhelp diff --git a/pkg/images/imfit/fit1d.par b/pkg/images/imfit/fit1d.par new file mode 100644 index 00000000..f28100ba --- /dev/null +++ b/pkg/images/imfit/fit1d.par @@ -0,0 +1,16 @@ +input,s,a,,,,Images to be fit +output,s,a,,,,Output images +bpm,s,h,"",,,Bad pixel mask(s) +axis,i,h,1,1,2,Axis to be fit +type,s,a,,,,"Type of output (fit, difference, ratio)" +interactive,b,h,yes,,,Set fitting parameters interactively? +sample,s,h,"*",,,Sample points to use in fit +naverage,i,h,1,,,Number of points in sample averaging +function,s,h,"spline3","spline3|legendre|chebyshev|spline1",,Fitting function +order,i,h,1,1,,Order of fitting function +low_reject,r,h,0.,0.,,Low rejection in sigma of fit +high_reject,r,h,0.,0.,,High rejection in sigma of fit +niterate,i,h,1,0,,Number of rejection iterations +grow,r,h,0.,0.,,Rejection growing radius in pixels +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/pkg/images/imfit/imfit.cl b/pkg/images/imfit/imfit.cl new file mode 100644 index 00000000..acde0687 --- /dev/null +++ b/pkg/images/imfit/imfit.cl @@ -0,0 +1,13 @@ +#{ IMFIT -- The Image Fitting Package. + +set imfit = "images$imfit/" + +package imfit + +# Tasks. + +task fit1d, + imsurfit, + lineclean = "imfit$x_images.e" + +clbye() diff --git a/pkg/images/imfit/imfit.hd b/pkg/images/imfit/imfit.hd new file mode 100644 index 00000000..adcc4d44 --- /dev/null +++ b/pkg/images/imfit/imfit.hd @@ -0,0 +1,10 @@ +# Help directory for the IMFIT package + +$doc = "images$imfit/doc/" +$src = "images$imfit/src/" + +fit1d hlp=doc$fit1d.hlp, src=src$fit1d.x +imsurfit hlp=doc$imsurfit.hlp, src=src$t_imsurfit.x +lineclean hlp=doc$lineclean.hlp, src=src$t_lineclean.x +revisions sys=Revisions + diff --git a/pkg/images/imfit/imfit.men b/pkg/images/imfit/imfit.men new file mode 100644 index 00000000..793b1c5e --- /dev/null +++ b/pkg/images/imfit/imfit.men @@ -0,0 +1,3 @@ + fit1d - Fit a function to image lines or columns + imsurfit - Fit a surface to a 2-D image + lineclean - Replace deviant pixels in image lines diff --git a/pkg/images/imfit/imfit.par b/pkg/images/imfit/imfit.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/imfit/imfit.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/imfit/imsurfit.par b/pkg/images/imfit/imsurfit.par new file mode 100644 index 00000000..1f21ffe5 --- /dev/null +++ b/pkg/images/imfit/imsurfit.par @@ -0,0 +1,24 @@ +# IMSURFIT + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +xorder,i,a,2,1,,Order of function in x +yorder,i,a,2,1,,Order of function in y +type_output,s,h,'fit',,,'Type of output (fit,residual,response,clean)' +function,s,h,'leg',,,'Function to be fit (legendre,chebyshev,spline3)' +cross_terms,b,h,y,,,Include cross-terms for polynomials? +xmedian,i,h,1,1,,X length of median box +ymedian,i,h,1,1,,Y length of median box +median_percent,r,h,50.,,,Minimum fraction of pixels in median box +lower,r,h,0.0,0.0,,Lower limit for residuals +upper,r,h,0.0,0.0,,Upper limit for residuals +ngrow,i,h,0,0,,Radius of region growing circle +niter,i,h,0,0,,Maximum number of rejection cycles +regions,s,h,'all',,, 'Good regions (all,rows,columns,border,sections,circle,invcircle)' +rows,s,h,'*',,,Rows to be fit +columns,s,h,'*',,,Columns to be fit +border,s,h,'50',,,Width of border to be fit +sections,s,h,,,,File name for sections list +circle,s,h,,,,Circle specifications +div_min,r,h,INDEF,,,Division minimum for response output +mode,s,h,'ql' diff --git a/pkg/images/imfit/lineclean.par b/pkg/images/imfit/lineclean.par new file mode 100644 index 00000000..5942f03f --- /dev/null +++ b/pkg/images/imfit/lineclean.par @@ -0,0 +1,13 @@ +input,s,a,,,,Images to be cleaned +output,s,a,,,,Output images +interactive,b,h,yes,,,Set fitting parameters interactively? +sample,s,h,"*",,,Sample points to use in fit +naverage,i,h,1,,,Number of points in sample averaging +function,s,h,"spline3","spline3|legendre|chebyshev|spline1",,Fitting function +order,i,h,1,1,,Order of fitting function +low_reject,r,h,2.5,0.,,Low rejection in sigma of fit +high_reject,r,h,2.5,0.,,High rejection in sigma of fit +niterate,i,h,1,0,,Number of rejection iterations +grow,r,h,1.,0.,,Rejection growing radius in pixels +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/pkg/images/imfit/mkpkg b/pkg/images/imfit/mkpkg new file mode 100644 index 00000000..a74a627e --- /dev/null +++ b/pkg/images/imfit/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMFIT Package + +libpkg.a: + @src + ; diff --git a/pkg/images/imfit/src/fit1d.x b/pkg/images/imfit/src/fit1d.x new file mode 100644 index 00000000..84ffddf1 --- /dev/null +++ b/pkg/images/imfit/src/fit1d.x @@ -0,0 +1,597 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define MAXBUF (512*100) # Maximum number of pixels per block + + +# FIT1D -- Fit a function to image lines or columns and output an image +# consisting of the fit, the difference, or the ratio. The fitting parameters +# may be set interactively using the icfit package. + +procedure t_fit1d () + +int listin # Input image list +int listout # Output image list +int listbpm # Bad pixel mask list +bool interactive # Interactive? + +char sample[SZ_LINE] # Sample ranges +int naverage # Sample averaging size +char function[SZ_LINE] # Curve fitting function +int order # Order of curve fitting function +real low_reject, high_reject # Rejection thresholds +int niterate # Number of rejection iterations +real grow # Rejection growing radius + +int axis # Image axis to fit +int ntype # Type of output +char input[SZ_LINE] # Input image +char output[SZ_FNAME] # Output image +char bpm[SZ_FNAME] # Bad pixel mask +pointer in, out, bp # IMIO pointers +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer + +bool same, clgetb() +int imtopen(), imtgetim(), imtlen(), strdic(), gt_init() +int clgeti() +real clgetr() + +begin + # Get input and output lists and check that the number of images + # are the same. + + call clgstr ("input", input, SZ_LINE) + listin = imtopen (input) + call clgstr ("output", input, SZ_LINE) + listout = imtopen (input) + if (imtlen (listin) != imtlen (listout)) { + call imtclose (listin) + call imtclose (listout) + call error (0, "Input and output image lists do not match") + } + call clgstr ("bpm", input, SZ_LINE) + listbpm = imtopen (input) + if (imtlen (listbpm) > 1 && imtlen (listin) != imtlen (listbpm)) { + call imtclose (listin) + call imtclose (listout) + call imtclose (listbpm) + call error (0, "Input and mask lists do not match") + } + + # Get task parameters. + + axis = clgeti ("axis") + call clgstr ("type", input, SZ_LINE) + call clgstr ("sample", sample, SZ_LINE) + naverage = clgeti ("naverage") + call clgstr ("function", function, SZ_LINE) + order = clgeti ("order") + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + niterate = clgeti ("niterate") + grow = clgetr ("grow") + interactive = clgetb ("interactive") + + # Decode the output type and initialize the curve fitting package. + + ntype = strdic (input, input, SZ_LINE, "|fit|difference|ratio|") + if (ntype == 0) + call error (0, "Unknown output type") + + # Set the ICFIT pointer structure. + call ic_open (ic) + call ic_pstr (ic, "sample", sample) + call ic_puti (ic, "naverage", naverage) + call ic_pstr (ic, "function", function) + call ic_puti (ic, "order", order) + call ic_putr (ic, "low", low_reject) + call ic_putr (ic, "high", high_reject) + call ic_puti (ic, "niterate", niterate) + call ic_putr (ic, "grow", grow) + call ic_pstr (ic, "ylabel", "") + + gt = gt_init() + call gt_sets (gt, GTTYPE, "line") + + # Fit the lines in each input image. + + bpm[1] = EOS + while ((imtgetim (listin, input, SZ_LINE) != EOF) && + (imtgetim (listout, output, SZ_FNAME) != EOF)) { + if (imtgetim (listbpm, bpm, SZ_FNAME) == EOF) + ; + + iferr (call f1d_immap (input,output,bpm,ntype,in,out,bp,same)) { + call erract (EA_WARN) + next + } + call f1d_fit1d (in,out,bp,ic,gt,input,axis,ntype,interactive) + call imunmap (in) + if (!same) + call imunmap (out) + if (bp != NULL) + call yt_pmunmap (bp) + } + + call ic_closer (ic) + call gt_free (gt) + call imtclose (listin) + call imtclose (listout) +end + + +# F1D_FIT1D -- Given the image descriptor determine the fitting function +# for each line or column and create an output image. If the interactive flag +# is set then set the fitting parameters interactively. + +procedure f1d_fit1d (in, out, bp, ic, gt, title, axis, ntype, interactive) + +pointer in # IMIO pointer for input image +pointer out # IMIO pointer for output image +pointer bp # IMIO pointer for bad pixel mask +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +char title[ARB] # Title +int axis # Image axis to fit +int ntype # Type of output +bool interactive # Interactive? + +char graphics[SZ_FNAME] # Graphics device +int i, nx, new +real div +pointer cv, gp, sp, x, wts, indata, outdata + +int f1d_getline(), f1d_getdata(), strlen() +real cveval() +pointer gopen() + +begin + # Error check. + + if (IM_NDIM (in) > 2) + call error (0, "Image dimensions > 2 are not implemented") + if (axis > IM_NDIM (in)) + call error (0, "Axis exceeds image dimension") + + # Allocate memory for curve fitting. + + nx = IM_LEN (in, axis) + call smark (sp) + call salloc (x, nx, TY_REAL) + + do i = 1, nx + Memr[x+i-1] = i + + call ic_putr (ic, "xmin", Memr[x]) + call ic_putr (ic, "xmax", Memr[x+nx-1]) + + # If the interactive flag is set then use icg_fit to set the + # fitting parameters. Get_fitline returns EOF when the user + # is done. The weights are reset since the user may delete + # points. + + if (interactive) { + call clgstr ("graphics", graphics, SZ_FNAME) + gp = gopen (graphics, NEW_FILE, STDGRAPH) + + i = strlen (title) + indata = NULL + while (f1d_getline (ic,gt,in,bp,axis,title,indata,wts) != EOF) { + title[i + 1] = EOS + call icg_fit (ic, gp, "cursor", gt, cv, Memr[x], Memr[indata], + Memr[wts], nx) + } + call mfree (indata, TY_REAL) + call mfree (wts, TY_REAL) + call gclose (gp) + } + + # Loop through the input image and create an output image. + + new = YES + + while (f1d_getdata (in,out,bp,axis,MAXBUF,indata,outdata,wts) != EOF) { + + call ic_fit (ic, cv, Memr[x], Memr[indata], Memr[wts], + nx, new, YES, new, new) + new = NO + + # Be careful because the indata and outdata buffers may be the same. + switch (ntype) { + case 1: + call cvvector (cv, Memr[x], Memr[outdata], nx) + case 2: + do i = 0, nx-1 + Memr[outdata+i] = Memr[indata+i] - cveval (cv, Memr[x+i]) + case 3: + do i = 0, nx-1 { + div = cveval (cv, Memr[x+i]) + if (abs (div) < 1E-20) + div = 1 + Memr[outdata+i] = Memr[indata+i] / div + } + } + } + + call cvfree (cv) + call mfree (wts, TY_REAL) + call sfree (sp) +end + + +# F1D_IMMAP -- Map images for fit1d. + +procedure f1d_immap (input, output, bpm, ntype, in, out, bp, same) + +char input[ARB] # Input image +char output[ARB] # Output image +char bpm[ARB] # Bad pixel mask +int ntype # Type of fit1d output +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +pointer bp # Mask IMIO pointer +bool same # Same image? + +int i +pointer sp, iroot, isect, oroot, osect, line, data + +bool streq() +int imaccess(), impnlr() +pointer immap(), yt_pmmap() +errchk immap, yt_pmmap + +begin + # Get the root name and section of the input image. + + call smark (sp) + call salloc (iroot, SZ_FNAME, TY_CHAR) + call salloc (isect, SZ_FNAME, TY_CHAR) + call salloc (oroot, SZ_FNAME, TY_CHAR) + call salloc (osect, SZ_FNAME, TY_CHAR) + + call imgimage (input, Memc[iroot], SZ_FNAME) + call imgsection (input, Memc[isect], SZ_FNAME) + call imgimage (output, Memc[oroot], SZ_FNAME) + call imgsection (output, Memc[osect], SZ_FNAME) + same = streq (Memc[iroot], Memc[oroot]) + + # If the output image is not accessible then create it as a new copy + # of the full input image and initialize according to ntype. + + if (imaccess (output, READ_WRITE) == NO) { + in = immap (Memc[iroot], READ_ONLY, 0) + out = immap (Memc[oroot], NEW_COPY, in) + IM_PIXTYPE(out) = TY_REAL + + call salloc (line, IM_MAXDIM, TY_LONG) + call amovkl (long (1), Meml[line], IM_MAXDIM) + + switch (ntype) { + case 1, 2: + while (impnlr (out, data, Meml[line]) != EOF) + call aclrr (Memr[data], IM_LEN(out, 1)) + case 3: + while (impnlr (out, data, Meml[line]) != EOF) + call amovkr (1., Memr[data], IM_LEN(out, 1)) + } + + call imunmap (in) + call imunmap (out) + } + + # Map the images. If the output image has a section + # then use it. If the input image has a section and the output image + # does not then add the image section to the output image. Finally + # check the input and output images have the same size. + + in = immap (input, READ_ONLY, 0) + + if (Memc[isect] != EOS && Memc[osect] == EOS) { + call sprintf (Memc[osect], SZ_FNAME, "%s%s") + call pargstr (Memc[oroot]) + call pargstr (Memc[isect]) + } else + call strcpy (output, Memc[osect], SZ_FNAME) + + if (streq (input, Memc[osect])) { + call imunmap (in) + in = immap (input, READ_WRITE, 0) + out = in + } else + out = immap (Memc[osect], READ_WRITE, 0) + + do i = 1, IM_NDIM(in) + if (IM_LEN(in, i) != IM_LEN(out, i)) { + call imunmap (in) + if (!same) + call imunmap (out) + call sfree (sp) + call error (0, "Input and output images have different sizes") + } + + bp = yt_pmmap (bpm, in, Memc[iroot], SZ_FNAME) + + call sfree (sp) +end + + +# F1D_GETDATA -- Get a line of image data. + +int procedure f1d_getdata (in, out, bp, axis, maxbuf, indata, outdata, wts) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +pointer bp # Bad pixel mask IMIO pointer +int axis # Image axis +int maxbuf # Maximum buffer size for column axis +pointer indata # Input data pointer +pointer outdata # Output data pointer +pointer wts # Weights pointer + +int i, index, last_index, col1, col2, nc, ncols, nlines, ncols_block +pointer inbuf, outbuf, wtbuf, ptr +pointer imgl1r(), imgl1s(), impl1r(), imgl2r(), imgl2s(), impl2r() +pointer imgs2r(), imgs2s(), imps2r() +data index/0/ + +begin + # Increment to the next image vector. + + index = index + 1 + + # Initialize for the first vector. + + if (index == 1) { + ncols = IM_LEN (in, 1) + if (IM_NDIM (in) == 1) + nlines = 1 + else + nlines = IM_LEN (in, 2) + + switch (axis) { + case 1: + last_index = nlines + + call malloc (wts, ncols, TY_REAL) + case 2: + last_index = ncols + ncols_block = max (1, min (ncols, maxbuf / nlines)) + col2 = 0 + + call malloc (indata, nlines, TY_REAL) + call malloc (outdata, nlines, TY_REAL) + call malloc (wts, nlines, TY_REAL) + } + } + + # Finish up if the last vector has been done. + + if (index > last_index) { + switch (axis) { + case 1: + call mfree (wts, TY_REAL) + case 2: + ptr = outbuf + index - 1 - col1 + do i = 1, nlines { + Memr[ptr] = Memr[outdata+i-1] + ptr = ptr + nc + } + + call mfree (indata, TY_REAL) + call mfree (outdata, TY_REAL) + call mfree (wts, TY_REAL) + } + + index = 0 + return (EOF) + } + + # Get the next image vector. + + switch (axis) { + case 1: + ncols = IM_LEN(in,1) + if (IM_NDIM (in) == 1) { + indata = imgl1r (in) + outdata = impl1r (out) + if (bp == NULL) + call amovkr (1., Memr[wts], ncols) + else { + wtbuf = imgl1s (bp) + do i = 0, ncols-1 { + if (Mems[wtbuf+i] == 0) + Memr[wts+i] = 1. + else + Memr[wts+i] = 0. + } + } + } else { + indata = imgl2r (in, index) + outdata = impl2r (out, index) + if (bp == NULL) + call amovkr (1., Memr[wts], ncols) + else { + wtbuf = imgl2s (bp, index) + do i = 0, ncols-1 { + if (Mems[wtbuf+i] == 0) + Memr[wts+i] = 1. + else + Memr[wts+i] = 0. + } + } + } + case 2: + if (index > 1) { + ptr = outbuf + index - 1 - col1 + do i = 1, nlines { + Memr[ptr] = Memr[outdata+i-1] + ptr = ptr + nc + } + } + + if (index > col2) { + col1 = col2 + 1 + col2 = min (ncols, col1 + ncols_block - 1) + inbuf = imgs2r (in, col1, col2, 1, nlines) + outbuf = imps2r (out, col1, col2, 1, nlines) + if (bp != NULL) + wtbuf = imgs2s (bp, col1, col2, 1, nlines) + nc = col2 - col1 + 1 + } + + ptr = inbuf + index - col1 + do i = 0, nlines-1 { + Memr[indata+i] = Memr[ptr] + ptr = ptr + nc + } + + if (bp == NULL) + call amovkr (1., Memr[wts], nlines) + else { + ptr = wtbuf + index - col1 + do i = 0, nlines-1 { + if (Mems[ptr] == 0) + Memr[wts+i] = 1. + else + Memr[wts+i] = 0. + ptr = ptr + nc + } + } + } + + return (index) +end + + +# F1D_GETLINE -- Get image data to be fit interactively. Return EOF +# when the user enters EOF or CR. Default is 1 and the out of bounds +# requests are silently limited to the nearest in edge. + +int procedure f1d_getline (ic, gt, im, bp, axis, title, data, wts) + +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +pointer im # IMIO pointer input image +pointer bp # IMIO pointer for bad pixel mask +int axis # Image axis +char title[ARB] # Title +pointer data # Image data +pointer wts # Weights + +pointer x, wtbuf +char line[SZ_LINE] +int i, j, stat, imlen +int getline(), nscan() +pointer imgl1r(), imgl1s() +data stat/EOF/ + +begin + # If the image is one dimensional do not prompt. + + if (IM_NDIM (im) == 1) { + if (stat == EOF) { + call sprintf (title, SZ_LINE, "%s\n%s") + call pargstr (title) + call pargstr (IM_TITLE(im)) + call gt_sets (gt, GTTITLE, title) + call mfree (data, TY_REAL) + imlen = IM_LEN(im,1) + call malloc (data, imlen, TY_REAL) + call amovr (Memr[imgl1r(im)], Memr[data], imlen) + call malloc (wts, imlen, TY_REAL) + if (bp == NULL) + call amovkr (1., Memr[wts], imlen) + else { + wtbuf = imgl1s (bp) + do i = 0, imlen-1 { + if (Mems[wtbuf+i] == 0) + Memr[wts+i] = 1. + else + Memr[wts+i] = 0. + } + } + stat = OK + } else + stat = EOF + + return (stat) + } + + # If the image is two dimensional prompt for the line or column. + + switch (axis) { + case 1: + imlen = IM_LEN (im, 2) + call sprintf (title, SZ_LINE, "%s: Fit line =") + call pargstr (title) + case 2: + imlen = IM_LEN (im, 1) + call sprintf (title, SZ_LINE, "%s: Fit column =") + call pargstr (title) + } + + call printf ("%s ") + call pargstr (title) + call flush (STDOUT) + + if (getline(STDIN, line) == EOF) + return (EOF) + + call sscan (line) + call gargi (i) + call gargi (j) + + switch (nscan()) { + case 0: + stat = EOF + return (stat) + case 1: + i = max (1, min (imlen, i)) + j = i + case 2: + i = max (1, min (imlen, i)) + j = max (1, min (imlen, j)) + } + + call sprintf (title, SZ_LINE, "%s %d - %d\n%s") + call pargstr (title) + call pargi (i) + call pargi (j) + call pargstr (IM_TITLE(im)) + + call gt_sets (gt, GTTITLE, title) + + call malloc (wts, imlen, TY_REAL) + switch (axis) { + case 1: + call ic_pstr (ic, "xlabel", "Column") + call xt_21imavg (im, axis, 1, IM_LEN(im,1), i, j, x, data, imlen) + if (bp != NULL) + call xt_21imsum (bp, axis, 1, IM_LEN(im,1), i, j, x, wts, imlen) + case 2: + call ic_pstr (ic, "xlabel", "Line") + call xt_21imavg (im, axis, i, j, 1, IM_LEN(im,2), x, data, imlen) + if (bp != NULL) + call xt_21imsum (bp, axis, i, j, 1, IM_LEN(im,2), x, wts, imlen) + } + if (bp == NULL) { + call mfree (wts, TY_REAL) + call malloc (wts, imlen, TY_REAL) + call amovkr (1., Memr[wts], imlen) + } else { + do i = 0, imlen-1 { + if (Memr[wts+i] == 0.) + Memr[wts+i] = 1. + else + Memr[wts+i] = 0. + } + } + call mfree (x, TY_REAL) + + stat = OK + return (stat) +end diff --git a/pkg/images/imfit/src/imsurfit.h b/pkg/images/imfit/src/imsurfit.h new file mode 100644 index 00000000..84c077ec --- /dev/null +++ b/pkg/images/imfit/src/imsurfit.h @@ -0,0 +1,40 @@ +# Header file for IMSURFIT + +define LEN_IMSFSTRUCT 20 + +# surface parameters +define SURFACE_TYPE Memi[$1] +define XORDER Memi[$1+1] +define YORDER Memi[$1+2] +define CROSS_TERMS Memi[$1+3] +define TYPE_OUTPUT Memi[$1+4] + +# median processing parameters +define MEDIAN Memi[$1+5] +define XMEDIAN Memi[$1+6] +define YMEDIAN Memi[$1+7] +define MEDIAN_PERCENT Memr[P2R($1+8)] + +# pixel rejection parameters +define REJECT Memi[$1+9] +define NGROW Memi[$1+10] +define NITER Memi[$1+11] +define LOWER Memr[P2R($1+12)] +define UPPER Memr[P2R($1+13)] + +define DIV_MIN Memr[P2R($1+14)] + +# definitions for type_output +define FIT 1 +define CLEAN 2 +define RESID 3 +define RESP 4 + +# definitions for good regions +define ALL 1 +define COLUMNS 2 +define ROWS 3 +define BORDER 4 +define SECTIONS 5 +define CIRCLE 6 +define INVCIRCLE 7 diff --git a/pkg/images/imfit/src/imsurfit.x b/pkg/images/imfit/src/imsurfit.x new file mode 100644 index 00000000..9f655f52 --- /dev/null +++ b/pkg/images/imfit/src/imsurfit.x @@ -0,0 +1,1172 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imsurfit.h" + +# IMSURFIT -- Procedure to fit a surface to a single image including +# optional pixel rejection. + +procedure imsurfit (imin, imout, imfit, gl) + +pointer imin # pointer to the input image +pointer imout # pointer to the output image +pointer imfit # pointer to the imsurfit parameters +pointer gl # pointer to the good regions list + +pointer sf, rl +errchk isfree, prl_free +errchk all_pixels, good_pixels, good_median, all_medians, do_reject +errchk set_outimage + +begin + sf = NULL + rl = NULL + + # Accumulate and solve the surface. + if (gl == NULL) { + if (MEDIAN(imfit) == NO) + call all_pixels (imin, imfit, sf) + else + call all_medians (imin, imfit, sf) + } else { + if (MEDIAN(imfit) == NO) + call good_pixels (imin, imfit, gl, sf) + else + call good_medians (imin, imfit, gl, sf) + } + + # Perform the reject cycle. + if (REJECT(imfit) == YES || TYPE_OUTPUT(imfit) == CLEAN) + call do_reject (imin, imfit, gl, sf, rl) + + # Evaluate surface for appropriate output type. + call set_outimage (imin, imout, imfit, sf, rl) + + # Cleanup. + call prl_free (rl) + call isfree (sf) + + rl = NULL + sf = NULL +end + + +# ALL_PIXELS -- Accumulate surface when there are no bad regions +# and no median processing. + +procedure all_pixels (im, imfit, sf) + +pointer im # pointer to the input image +pointer imfit # pointer to the imsurfit structure +pointer sf # pointer to the surface descriptor + +int i, lp, ncols, nlines, ier +long v[IM_MAXDIM] +pointer sp, cols, lines, wgt, lbuf +int imgnlr() +errchk smark, salloc, sfree, imgnlr +errchk isinit, islfit, islrefit, issolve + +begin + ncols = IM_LEN(im, 1) + nlines = IM_LEN(im,2) + + # Initialize the surface fit. + call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), + CROSS_TERMS(imfit), ncols, nlines) + + # Allocate working space for fitting. + call smark (sp) + call salloc (cols, ncols, TY_INT) + call salloc (lines, nlines, TY_INT) + call salloc (wgt, ncols, TY_REAL) + + # Initialize the x and weight buffers. + do i = 1, ncols + Memi[cols - 1 + i] = i + call amovkr (1.0, Memr[wgt], ncols) + + # Loop over image lines. + lp = 0 + call amovkl (long (1), v, IM_MAXDIM) + do i = 1, nlines { + + # Read in the image line. + if (imgnlr (im, lbuf, v) == EOF) + call error (0, "Error reading image") + + # Fit each image line. + if (i == 1) + call islfit (sf, Memi[cols], i, Memr[lbuf], Memr[wgt], + ncols, SF_USER, ier) + else + call islrefit (sf, Memi[cols], i, Memr[lbuf], Memr[wgt]) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call eprintf ("Warning: Too few columns to fit line: %d\n") + call pargi (i) + case SINGULAR: + call eprintf ("Warning: Solution singular for line: %d\n") + call pargi (i) + Memi[lines + lp] = i + lp = lp + 1 + default: + Memi[lines + lp] = i + lp = lp + 1 + } + + } + + # Solve the surface. + call issolve (sf, Memi[lines], lp, ier) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call error (0, "ALL_PIXELS: Cannot fit surface.") + case SINGULAR: + call eprintf ("Warning: Solution singular for surface.\n") + default: + # everything OK + } + + # Free space. + call sfree (sp) +end + + +# GOOD_PIXELS -- Get surface when good regions are defined and median +# processing is off. + +procedure good_pixels (im, imfit, gl, sf) + +pointer im # input image +pointer imfit # pointer to imsurfit header structure +pointer gl # pointer to good region list +pointer sf # pointer to the surface descriptor + +int lp, lineno, prevlineno, ncols, nlines, npts, nranges, ier, ijunk +int max_nranges +pointer sp, colsfit, lines, buf, fbuf, wgt, ranges +int prl_nextlineno(), prl_eqlines(), prl_get_ranges(), is_expand_ranges() +int is_choose_rangesr() +pointer imgl2r() + +errchk smark, salloc, sfree, imgl2r +errchk isinit, islfit, islrefit, issolve +errchk prl_nextlineno, prl_eqlines, prl_get_ranges +errchk is_choose_rangesr + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + max_nranges = ncols + + # Initialize the surface fit. + call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), + CROSS_TERMS(imfit), ncols, nlines) + + # Allocate temporary space for fitting. + call smark (sp) + call salloc (colsfit, ncols, TY_INT) + call salloc (lines, nlines, TY_INT) + call salloc (fbuf, ncols, TY_REAL) + call salloc (wgt, ncols, TY_REAL) + call salloc (ranges, 3 * max_nranges + 1, TY_INT) + call amovkr (1., Memr[wgt], ncols) + + # Intialize counters and pointers. + lp = 0 + lineno = 0 + prevlineno = 0 + + # Loop over those lines to be fit. + while (prl_nextlineno (gl, lineno) != EOF) { + + # Read in the image line. + buf = imgl2r (im, lineno) + if (buf == EOF) + call error (0, "GOOD_PIXELS: Error reading image.") + + # Get the ranges for that image line. + nranges = prl_get_ranges (gl, lineno, Memi[ranges], max_nranges) + if (nranges == 0) + next + + # If ranges are not equal to previous line fit else refit. + if (lp == 0 || prl_eqlines (gl, lineno, prevlineno) == NO) { + npts = is_expand_ranges (Memi[ranges], Memi[colsfit], ncols) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], + npts, 1, ncols) + call islfit (sf, Memi[colsfit], lineno, Memr[fbuf], Memr[wgt], + npts, SF_USER, ier) + } else { + ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], + npts, 1, ncols) + call islrefit (sf, Memi[colsfit], lineno, Memr[fbuf], Memr[wgt]) + } + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call eprintf ("Warning: Too few columns to fit line: %d\n") + call pargi (lineno) + case SINGULAR: + call eprintf ("Warning: Solution singular for line: %d\n") + call pargi (lineno) + Memi[lines+lp] = lineno + lp = lp + 1 + default: + Memi[lines+lp] = lineno + lp = lp + 1 + } + + prevlineno = lineno + } + + # Solve the surface. + call issolve (sf, Memi[lines], lp, ier) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call error (0, "GOOD_PIXELS: Cannot fit surface.") + case SINGULAR: + call eprintf ("Warning: Solution singular for surface.\n") + default: + # everything OK + } + + # Free space. + call sfree (sp) +end + + +# ALL_MEDIANS -- Get surface when median processor on and all +# pixels good. + +procedure all_medians (im, imfit, sf) + +pointer im # input image +pointer imfit # pointer to the imsurfit header structure +pointer sf # pointer to the surface descriptor + +int i, lp, cp, op, lineno, x1, x2, y1, y2, ier +int nimcols, nimlines, ncols, nlines, npts +pointer sp, cols, lines, wgt, z, med, sbuf, lbuf, buf + +pointer imgs2r() +real asokr() +errchk salloc, sfree, smark +errchk isinit, islfit, islrefit, issolve + +begin + # Determine the number of lines and columns for a median processed + # image. + nimcols = IM_LEN(im,1) + if (mod (int (IM_LEN(im,1)), XMEDIAN(imfit)) != 0) + ncols = IM_LEN(im,1) / XMEDIAN(imfit) + 1 + else + ncols = IM_LEN(im,1) / XMEDIAN(imfit) + nimlines = IM_LEN(im,2) + if (mod (int (IM_LEN(im,2)), YMEDIAN(imfit)) != 0) + nlines = IM_LEN(im,2) / YMEDIAN(imfit) + 1 + else + nlines = IM_LEN(im,2) / YMEDIAN(imfit) + + # Initialize the surface fitting. + call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), + CROSS_TERMS(imfit), ncols, nlines) + + # Allocate workin memory. + call smark (sp) + call salloc (cols, ncols, TY_INT) + call salloc (wgt, ncols, TY_REAL) + call salloc (lines, nlines, TY_INT) + call salloc (z, ncols, TY_REAL) + call salloc (med, XMEDIAN(imfit) * YMEDIAN(imfit), TY_REAL) + + # Intialize the x and weight arrays. + do i = 1, ncols + Memi[cols - 1 + i] = i + call amovkr (1.0, Memr[wgt], ncols) + + # Loop over image sections. + lp = 0 + lineno = 1 + for (y1 = 1; y1 <= nimlines; y1 = y1 + YMEDIAN(imfit)) { + + # Get image section. + y2 = min (y1 + YMEDIAN(imfit) - 1, nimlines) + sbuf = imgs2r (im, 1, nimcols, y1, y2) + if (sbuf == EOF) + call error (0, "Error reading image section.") + + # Loop over median boxes. + cp = 0 + for (x1 = 1; x1 <= nimcols; x1 = x1 + XMEDIAN(imfit)) { + + x2 = min (x1 + XMEDIAN(imfit) - 1, nimcols) + npts = x2 - x1 + 1 + lbuf = sbuf - 1 + x1 + + # Loop over lines in the median box. + op = 0 + buf = lbuf + for (i = 1; i <= y2 - y1 + 1; i = i + 1) { + call amovr (Memr[buf], Memr[med+op], npts) + op = op + npts + buf = buf + nimcols + } + + # Calculate the median. + Memr[z+cp] = asokr (Memr[med], op, (op + 1) / 2) + cp = cp + 1 + + } + + # Fit each image "line". + if (y1 == 1) + call islfit (sf, Memi[cols], lineno, Memr[z], Memr[wgt], + ncols, SF_USER, ier) + else + call islrefit (sf, Memi[cols], lineno, Memr[z], Memr[wgt]) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call eprintf ("Warning: Too few columns to fit line: %d\n") + call pargi (lineno) + case SINGULAR: + call eprintf ("Warning: Solution singular for line: %d\n") + call pargi (lineno) + Memi[lines + lp] = lineno + lp = lp + 1 + default: + Memi[lines + lp] = lineno + lp = lp + 1 + } + + lineno = lineno + 1 + } + + # Solve th surface. + call issolve (sf, Memi[lines], lp, ier) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call error (0, "ALL_MEDIANS: Cannot fit surface.") + case SINGULAR: + call eprintf ("Warning: Solution singular for surface.\n") + default: + # everything OK + } + + # Free space + call sfree (sp) +end + + +# GOOD_MEDIANS -- Procedure to fetch medians when the good regions +# list is defined. + +procedure good_medians (im, imfit, gl, sf) + +pointer im # input image +pointer imfit # pointer to surface descriptor structure +pointer gl # pointer to good regions list +pointer sf # pointer the surface descriptor + +int i, cp, lp, x1, x2, y1, y2, ier, ntemp +int nimcols, nimlines, ncols, nlines, nranges, nbox, nxpts +int lineno, current_line, lines_per_box, max_nranges +pointer sp, colsfit, cols, lines, wgt, npts, lbuf, med, mbuf, z, ranges + +int prl_get_ranges(), prl_nextlineno(), is_expand_ranges() +int is_choose_rangesr() +pointer imgl2r() +real asokr() +errchk smark, salloc, sfree, imgl2r +errchk isinit, islfit, issolve +errchk prl_get_ranges, prl_nextlineno, is_choose_rangesr() + +begin + # Determine the number of lines and columns for a median processed + # image. + nimcols = IM_LEN(im,1) + if (mod (int (IM_LEN(im,1)), XMEDIAN(imfit)) != 0) + ncols = IM_LEN(im,1) / XMEDIAN(imfit) + 1 + else + ncols = IM_LEN(im,1) / XMEDIAN(imfit) + nimlines = IM_LEN(im,2) + if (mod (int (IM_LEN(im,2)), YMEDIAN(imfit)) != 0) + nlines = IM_LEN(im,2) / YMEDIAN(imfit) + 1 + else + nlines = IM_LEN(im,2) / YMEDIAN(imfit) + nbox = XMEDIAN(imfit) * YMEDIAN(imfit) + max_nranges = nimcols + + # Initialize the surface fitting. + call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), + CROSS_TERMS(imfit), ncols, nlines) + + # Allocate working memory. + call smark (sp) + call salloc (colsfit, nimcols, TY_INT) + call salloc (cols, ncols, TY_INT) + call salloc (npts, ncols, TY_INT) + call salloc (lines, nlines, TY_INT) + call salloc (wgt, ncols, TY_REAL) + call salloc (med, nbox * ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + call salloc (ranges, 3 * max_nranges + 1, TY_INT) + call amovkr (1., Memr[wgt], ncols) + + # Loop over median boxes in y. + lp = 0 + lineno = 0 + for (y1 = 1; y1 <= nimlines; y1 = y1 + YMEDIAN(imfit)) { + + lineno = lineno + 1 + current_line = y1 - 1 + y2 = min (y1 + YMEDIAN(imfit) - 1, nimlines) + + # If lines not in range, next image section. + lines_per_box = 0 + while (prl_nextlineno (gl, current_line) != EOF) { + if (current_line > y2) + break + lines_per_box = lines_per_box + 1 + } + if (lines_per_box < (YMEDIAN(imfit) * (MEDIAN_PERCENT(imfit)/100.))) + next + + # Loop over the image lines. + call aclri (Memi[npts], ncols) + do i = y1, y2 { + + # Get image line, and check the good regions list. + lbuf = imgl2r (im, i) + nranges = prl_get_ranges (gl, i, Memi[ranges], max_nranges) + if (nranges == 0) + next + nxpts = is_expand_ranges (Memi[ranges], Memi[colsfit], nimcols) + + # Loop over the median boxes in x. + cp= 0 + mbuf = med + for (x1 = 1; x1 <= nimcols; x1 = x1 + XMEDIAN(imfit)) { + x2 = min (x1 + XMEDIAN(imfit) - 1, nimcols) + ntemp = is_choose_rangesr (Memi[colsfit], Memr[lbuf], + Memr[mbuf+Memi[npts+cp]], nxpts, x1, x2) + Memi[npts+cp] = Memi[npts+cp] + ntemp + mbuf = mbuf + nbox + cp = cp + 1 + } + } + + # Calculate the medians. + nxpts = 0 + mbuf = med + do i = 1, ncols { + if (Memi[npts+i-1] > ((MEDIAN_PERCENT(imfit) / 100.) * nbox)) { + Memr[z+nxpts] = asokr (Memr[mbuf], Memi[npts+i-1], + (Memi[npts+i-1] + 1) / 2) + Memi[cols+nxpts] = i + nxpts = nxpts + 1 + } + mbuf = mbuf + nbox + } + + # Fit the line. + call islfit (sf, Memi[cols], lineno, Memr[z], Memr[wgt], nxpts, + SF_USER, ier) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call eprintf ("Warning: Too few columns to fit line: %d\n") + call pargi (lineno) + case SINGULAR: + call eprintf ("Warning: Solution singular for line: %d\n") + call pargi (lineno) + Memi[lines+lp] = lineno + lp = lp + 1 + default: + Memi[lines+lp] = lineno + lp = lp + 1 + } + } + + # Solve the surface. + call issolve (sf, Memi[lines], lp, ier) + + # Handle fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call error (0, "GOOD_MEDIANS: Cannot fit surface.") + case SINGULAR: + call eprintf ("Warning: Solution singular for surface.") + default: + # everyting OK + } + + # Free space. + call sfree (sp) +end + + +# SET_OUTIMAGE -- Procedure to write an output image of the desired type. + +procedure set_outimage (imin, imout, imfit, sf, rl) + +pointer imin # input image +pointer imout # output image +pointer imfit # pointer to the imsurfut header structure +pointer sf # pointer to the surface descriptor +pointer rl # pointer to the rejected pixel list regions list + +int i, k, ncols, nlines, max_nranges +long u[IM_MAXDIM], v[IM_MAXDIM] +real b1x, b2x, b1y, b2y +pointer sp, x, y, inbuf, outbuf, ranges + +int impnlr(), imgnlr() +real ims_divzero() +extern ims_divzero +errchk malloc, mfree, imgnlr, impnlr + +begin + ncols = IM_LEN(imin,1) + nlines = IM_LEN(imin,2) + max_nranges = ncols + + # Calculate transformation constants from real coordinates to + # median coordinates if median processing specified. + if (MEDIAN(imfit) == YES) { + b1x = (1. + XMEDIAN(imfit)) / (2. * XMEDIAN(imfit)) + b2x = (2. * ncols + XMEDIAN(imfit) - 1.) / (2. * XMEDIAN(imfit)) + b1y = (1. + YMEDIAN(imfit)) / (2. * YMEDIAN(imfit)) + b2y = (2. * nlines + YMEDIAN(imfit) - 1.) / (2. * YMEDIAN(imfit)) + } + + # Allocate space for x coordinates, initialize to image coordinates + # and transform to median coordinates. + call smark (sp) + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (ranges, 3 * max_nranges + 1, TY_INT) + + # Intialize the x array. + do i = 1, ncols + Memr[x - 1 + i] = i + if (MEDIAN(imfit) == YES) + call amapr (Memr[x], Memr[x], ncols, 1., real (ncols), b1x, b2x) + + # loop over the images lines + call amovkl (long (1), v, IM_MAXDIM) + call amovkl (long (1), u, IM_MAXDIM) + do i = 1, nlines { + + # Get input and output image buffers. + if (TYPE_OUTPUT(imfit) != FIT) { + if (imgnlr (imin, inbuf, v) == EOF) + call error (0, "Error reading input image.") + } + if (impnlr (imout, outbuf, u) == EOF) + call error (0, "Error writing output image.") + + # Intialize y coordinates to image coordinates, and + # transform to median coordinates. + if (MEDIAN(imfit) == YES) { + Memr[y] = real (i) + call amapr (Memr[y], Memr[y], 1, 1., real (nlines), + b1y, b2y) + call amovkr (Memr[y], Memr[y+1], (ncols-1)) + } else + call amovkr (real (i), Memr[y], ncols) + + # Write output image. + switch (TYPE_OUTPUT(imfit)) { + case FIT: + call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) + case CLEAN: + call clean_line (Memr[x], Memr[y], Memr[inbuf], ncols, nlines, + rl, sf, i, NGROW(imfit)) + call amovr (Memr[inbuf], Memr[outbuf], ncols) + case RESID: + call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) + call asubr (Memr[inbuf], Memr[outbuf], Memr[outbuf], ncols) + case RESP: + call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) + if (IS_INDEF(DIV_MIN(imfit))) { + iferr (call adivr (Memr[inbuf], Memr[outbuf], Memr[outbuf], + ncols)) + call advzr (Memr[inbuf], Memr[outbuf], Memr[outbuf], + ncols, ims_divzero) + } else { + do k = 1, ncols { + if (Memr[outbuf-1+k] < DIV_MIN(imfit)) + Memr[outbuf-1+k] = 1. + else + Memr[outbuf-1+k] = Memr[inbuf-1+k] / + Memr[outbuf-1+k] + } + } + default: + call error (0, "SET_OUTIMAGE: Unknown output type.") + } + } + + # Free space + call sfree (sp) +end + + +# CLEAN_LINE -- Procedure to set weights of rejected points to zero + +procedure clean_line (x, y, z, ncols, nlines, rl, sf, line, ngrow) + +real x[ARB] # array of weights set to 1 +real y # y value of line +real z[ARB] # line of data +int ncols # number of image columns +int nlines # number of image lines +pointer rl # pointer to reject pixel list +pointer sf # surface fitting +int line # line number +int ngrow # radius for region growing + +int cp, j, k, nranges, dist, yreg_min, yreg_max, xreg_min, xreg_max +pointer sp, branges +real r2 +int prl_get_ranges(), is_next_number() +real iseval() + +begin + call smark (sp) + call salloc (branges, 3 * ncols + 1, TY_INT) + + r2 = ngrow ** 2 + yreg_min = max (1, line - ngrow) + yreg_max = min (nlines, line + ngrow) + + do j = yreg_min, yreg_max { + nranges = prl_get_ranges (rl, j, Memi[branges], ncols) + if (nranges == 0) + next + dist = int (sqrt (r2 - (j - line) ** 2)) + cp = 0 + while (is_next_number (Memi[branges], cp) != EOF) { + xreg_min = max (1, cp - dist) + xreg_max = min (ncols, cp + dist) + do k = xreg_min, xreg_max + z[k] = iseval (sf, x[k], y) + cp = xreg_max + } + } + + call sfree (sp) +end + + +# DO_REJECT -- Procedure to detect rejected pixels in an image. + +procedure do_reject (im, imfit, gl, sf, rl) + +pointer im # pointer to in put image +pointer imfit # pointer to image fitting structure +pointer gl # pointer to good regions list +pointer sf # pointer to surface descriptor +pointer rl # pointer to rejected pixel list + +int niter, nrejects +real sigma +int detect_rejects() +real get_sigma() +errchk prl_init, detect_rejects, get_sigma, refit_surface + +begin + # Initialize rejected pixel list. + call prl_init (rl, int(IM_LEN(im,1)), int(IM_LEN(im,2))) + + # Do an iterative rejection cycle on the image. + niter = 0 + repeat { + + # Get the sigma of the fit. + sigma = get_sigma (im, gl, sf, rl) + + # Detect rejected pixels. + nrejects = detect_rejects (im, imfit, gl, sf, rl, sigma) + + # If no rejected pixels quit, else refit surface. + if (nrejects == 0 || NITER(imfit) == 0) + break + call refit_surface (im, imfit, gl, sf, rl) + + niter = niter + 1 + + } until (niter == NITER(imfit)) +end + + +# REFIT_SURFACE -- Procedure tp refit the surface. + +procedure refit_surface (im, imfit, gl, sf, rl) + +pointer im # pointer to image +pointer imfit # pointer to surface fitting structure +pointer gl # pointer to good regions list +pointer sf # pointer to surface descriptor +pointer rl # pointer to rejected pixels list + +int i, ijunk, lp, ier, max_nranges +int ncols, nlines, npts, nfree, nrejects, nranges, ncoeff +pointer sp, cols, colsfit, lines, buf, fbuf, wgt, granges + +int prl_get_ranges(), grow_regions(), is_expand_ranges() +int is_choose_rangesr() +pointer imgl2r() +errchk smark, salloc, sfree, imgl2r +errchk iscoeff, islfit, issolve +errchk prl_get_ranges, grow_regions +errchk is_choose_rangesr + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + max_nranges = ncols + + # Allocate up temporary storage. + call smark (sp) + call salloc (cols, ncols, TY_INT) + call salloc (colsfit, ncols, TY_INT) + call salloc (lines, nlines, TY_INT) + call salloc (fbuf, ncols, TY_REAL) + call salloc (wgt, ncols, TY_REAL) + call salloc (granges, 3 * max_nranges + 1, TY_INT) + + # Initialize columns. + do i = 1, ncols + Memi[cols+i-1] = i + call amovi (Memi[cols], Memi[colsfit], ncols) + + # Get number of coefficients. + switch (SURFACE_TYPE(imfit)) { + case SF_LEGENDRE, SF_CHEBYSHEV: + ncoeff = XORDER(imfit) + case SF_SPLINE3: + ncoeff = XORDER(imfit) + 3 + case SF_SPLINE1: + ncoeff = XORDER(imfit) + 1 + } + + # Refit affected lines and solve for surface. + lp = 0 + do i = 1, nlines { + + # Determine whether image line is good. + if (gl != NULL) { + nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) + if (nranges == 0) + next + } + + # Define rejected points with region growing. + call amovkr (1., Memr[wgt], ncols) + nrejects = grow_regions (Memr[wgt], ncols, nlines, rl, i, + NGROW(imfit)) + + # Get number of data points. + if (gl == NULL) + npts = ncols + else + npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) + nfree = npts - nrejects + + # If no rejected pixels skip to next line. + if (nrejects == 0) { + if (nfree >= ncoeff ) { + Memi[lines+lp] = i + lp = lp + 1 + } + next + } + + # Read in image line. + buf = imgl2r (im, i) + if (buf == EOF) + call error (0, "REFIT_SURFACE: Error reading image.") + + # Select the data. + if (gl == NULL) { + npts = ncols + if (nfree >= ncoeff) + call islfit (sf, Memi[colsfit], i, Memr[buf], Memr[wgt], + npts, SF_USER, ier) + else + ier = NO_DEG_FREEDOM + } else { + ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], + Memr[fbuf], npts, 1, ncols) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], Memr[wgt], + npts, 1, ncols) + if (nfree >= ncoeff) + call islfit (sf, Memi[colsfit], i, Memr[fbuf], Memr[wgt], + npts, SF_USER, ier) + else + ier = NO_DEG_FREEDOM + } + + # Evaluate fitting errors. + switch (ier) { + case NO_DEG_FREEDOM: + call eprintf ("REFIT_SURFACE: Too few points to fit line: %d\n") + call pargi (i) + case SINGULAR: + call eprintf ("REFIT_SURFACE: Solution singular for line: %d\n") + call pargi (i) + Memi[lines+lp] = i + lp = lp + 1 + default: + Memi[lines+lp] = i + lp = lp + 1 + } + } + + # Resolve surface. + call issolve (sf, Memi[lines], lp, ier) + + # Evaluate fitting errors for surface. + switch (ier) { + case NO_DEG_FREEDOM: + call error (0, "REFIT_SURFACE: Too few points to fit surface\n") + case SINGULAR: + call eprintf ("REFIT_SURFACE: Solution singular for surface\n") + default: + # everything OK + } + + call sfree (sp) + +end + + +# GROW_REGIONS -- Procedure to set weights of rejected points to zero. + +int procedure grow_regions (wgt, ncols, nlines, rl, line, ngrow) + +real wgt[ARB] # array of weights set to 1 +int ncols # number of image columnspoints +int nlines # number of images lines +pointer rl # pointer to reject pixel list +int line # line number +int ngrow # radius for region growing + +int cp, j, k, nrejects, nranges, max_nranges +int dist, yreg_min, yreg_max, xreg_min, xreg_max +pointer sp, branges +real r2 +int prl_get_ranges(), is_next_number() +errchk smark, salloc, sfree +errchk prl_get_ranges, is_next_number + +begin + max_nranges = ncols + + call smark (sp) + call salloc (branges, 3 * max_nranges + 1, TY_INT) + + r2 = ngrow ** 2 + nrejects = 0 + yreg_min = max (1, line - ngrow) + yreg_max = min (nlines, line + ngrow) + + do j = yreg_min, yreg_max { + nranges = prl_get_ranges (rl, j, Memi[branges], max_nranges) + if (nranges == 0) + next + dist = int (sqrt (r2 - (j - line) ** 2)) + cp = 0 + while (is_next_number (Memi[branges], cp) != EOF) { + xreg_min = max (1, cp - dist) + xreg_max = min (ncols, cp + dist) + do k = xreg_min, xreg_max { + if (wgt[k] > 0.) { + wgt[k] = 0. + nrejects = nrejects + 1 + } + } + cp = xreg_max + } + } + + call sfree (sp) + return (nrejects) +end + + +# GET_SIGMA -- Procedure to calculate the sigma of the surface fit + +real procedure get_sigma (im, gl, sf, rl) + +pointer im # pointer to image +pointer gl # pointer to good pixel list +pointer sf # pointer to surface deascriptor +pointer rl # pointer to rejected pixel list + +int i, ijunk, cp, nranges, npts, ntpts, ncols, nlines, max_nranges +pointer sp, colsfit, x, xfit, y, zfit, buf, fbuf, wgt, granges, branges +real sum, sigma +int prl_get_ranges(), is_next_number(), is_expand_ranges() +int is_choose_rangesr() +pointer imgl2r() +real asumr(), awssqr() +errchk smark, salloc, sfree, imgl2r + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + max_nranges = ncols + + # Allocate working space. + call smark (sp) + call salloc (colsfit, ncols, TY_INT) + call salloc (x, ncols, TY_REAL) + call salloc (xfit, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (fbuf, ncols, TY_REAL) + call salloc (zfit, ncols, TY_REAL) + call salloc (wgt, ncols, TY_REAL) + call salloc (granges, 3 * max_nranges + 1, TY_INT) + call salloc (branges, 3 * max_nranges + 1, TY_INT) + + # Intialize the x array. + do i = 1, ncols + Memr[x+i-1] = i + call amovr (Memr[x], Memr[xfit], ncols) + + sum = 0. + sigma = 0. + ntpts = 0 + + # Loop over the image. + do i = 1, nlines { + + # Check that line is in range. + if (gl != NULL) { + nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) + if (nranges == 0) + next + npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) + } + + # Read in image. + buf = imgl2r (im, i) + if (buf == EOF) + call error (0, "GET_SIGMA: Error reading image.") + + # Select appropriate data and fit. + call amovkr (real (i), Memr[y], ncols) + if (gl == NULL) { + npts = ncols + call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) + call asubr (Memr[buf], Memr[zfit], Memr[zfit], npts) + } else { + ijunk = is_choose_rangesr (Memi[colsfit], Memr[x], Memr[xfit], + npts, 1, ncols) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], + npts, 1, ncols) + call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) + call asubr (Memr[fbuf], Memr[zfit], Memr[zfit], npts) + } + + # Get ranges of rejected pixels for the line and set weights. + call amovkr (1., Memr[wgt], ncols) + nranges = prl_get_ranges (rl, i, Memi[branges], max_nranges) + if (nranges > 0) { + cp = 0 + while (is_next_number (Memi[branges], cp) != EOF) + Memr[wgt+cp-1] = 0. + if (gl != NULL) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], + Memr[wgt], npts, 1, ncols) + } + + # Calculate sigma. + sigma = sigma + awssqr (Memr[zfit], Memr[wgt], npts) + ntpts = ntpts + asumr (Memr[wgt], npts) + } + + call sfree (sp) + + return (sqrt (sigma / (ntpts - 1))) +end + + +# DETECT_REJECTS - Procedure to detect rejected pixels. + +int procedure detect_rejects (im, imfit, gl, sf, rl, sigma) + +pointer im # pointer to image +pointer imfit # pointer to surface fitting structure +pointer gl # pointer to good pixel list +pointer sf # pointer to surface descriptor +pointer rl # pointer to rejected pixel list +real sigma # standard deviation of fit + +int i, j, ijunk, cp, ncols, nlines, npts, nranges, nlrejects, ntrejects +int norejects, max_nranges +pointer sp, granges, branges, x, xfit, cols, colsfit, y, zfit, buf, fbuf +pointer wgt, list +real upper, lower + +int prl_get_ranges(), is_next_number(), is_make_ranges(), is_expand_ranges() +int is_choose_rangesr() +pointer imgl2r() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + max_nranges = ncols + + # Allocate temporary space. + call smark (sp) + call salloc (x, ncols, TY_REAL) + call salloc (xfit, ncols, TY_REAL) + call salloc (cols, ncols, TY_INT) + call salloc (colsfit, ncols, TY_INT) + call salloc (y, ncols, TY_REAL) + call salloc (fbuf, ncols, TY_REAL) + call salloc (zfit, ncols, TY_REAL) + call salloc (wgt, ncols, TY_REAL) + call salloc (granges, 3 * max_nranges + 1, TY_INT) + call salloc (branges, 3 * max_nranges + 1, TY_INT) + call salloc (list, ncols, TY_INT) + + # Intialize x and column values. + do i = 1, ncols { + Memi[cols+i-1] = i + Memr[x+i-1] = i + } + call amovr (Memr[x], Memr[xfit], ncols) + call amovi (Memi[cols], Memi[colsfit], ncols) + + ntrejects = 0 + if (LOWER(imfit) <= 0.0) + lower = -MAX_REAL + else + lower = -sigma * LOWER(imfit) + if (UPPER(imfit) <= 0.0) + upper = MAX_REAL + else + upper = sigma * UPPER(imfit) + + # Loop over the image. + do i = 1, nlines { + + # Get ranges if appropriate. + if (gl != NULL) { + nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) + if (nranges == 0) + next + npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) + } + + # Read in image. + buf = imgl2r (im, i) + if (buf == EOF) + call error (0, "GET_SIGMA: Error reading image.") + + # Select appropriate data and fit. + call amovkr (real (i), Memr[y], ncols) + if (gl == NULL) { + npts = ncols + call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) + call asubr (Memr[buf], Memr[zfit], Memr[zfit], npts) + } else { + ijunk = is_choose_rangesr (Memi[colsfit], Memr[x], Memr[xfit], + npts, 1, ncols) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], + npts, 1, ncols) + call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) + call asubr (Memr[fbuf], Memr[zfit], Memr[zfit], npts) + } + + # Get ranges of rejected pixels for the line and set weights. + call amovkr (1., Memr[wgt], ncols) + nranges = prl_get_ranges (rl, i, Memi[branges], max_nranges) + norejects = 0 + if (nranges > 0) { + cp = 0 + while (is_next_number (Memi[branges], cp) != EOF) { + Memi[list+norejects] = cp + norejects = norejects + 1 + Memr[wgt+cp-1] = 0. + } + if (gl != NULL) + ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], + Memr[wgt], npts, 1, ncols) + } + + # Detect deviant pixels. + nlrejects = 0 + do j = 1, npts { + if ((Memr[zfit+j-1] < lower || Memr[zfit+j-1] > upper) && + Memr[wgt+j-1] != 0.) { + Memi[list+norejects+nlrejects] = Memi[colsfit+j-1] + nlrejects = nlrejects + 1 + } + } + + # Add to rejected pixel list. + if (nlrejects > 0) { + call asrti (Memi[list], Memi[list], norejects + nlrejects) + nranges = is_make_ranges (Memi[list], norejects + nlrejects, + Memi[granges], max_nranges) + call prl_put_ranges (rl, i, i, Memi[granges]) + } + + ntrejects = ntrejects + nlrejects + } + + call sfree (sp) + return (ntrejects) +end + + +# AWSSQR -- Procedure to calculate the weighted sum of the squares + +real procedure awssqr (a, w, npts) + +real a[npts] # array of data +real w[npts] # array of points +int npts # number of data points + +int i +real sum + +begin + sum = 0. + do i = 1, npts + sum = sum + w[i] * a[i] ** 2 + + return (sum) +end + + +# IMS_DIVZER0 -- Return 1. on a divide by zero + +real procedure ims_divzero (x) + +real x + +begin + return (1.) +end diff --git a/pkg/images/imfit/src/mkpkg b/pkg/images/imfit/src/mkpkg new file mode 100644 index 00000000..3bc27b8f --- /dev/null +++ b/pkg/images/imfit/src/mkpkg @@ -0,0 +1,15 @@ +# Library for the IMAGES IMFIT Subpackage Tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + fit1d.x + imsurfit.x imsurfit.h + pixlist.x pixlist.h + ranges.x + t_imsurfit.x imsurfit.h + t_lineclean.x + ; diff --git a/pkg/images/imfit/src/pixlist.h b/pkg/images/imfit/src/pixlist.h new file mode 100644 index 00000000..39c875a9 --- /dev/null +++ b/pkg/images/imfit/src/pixlist.h @@ -0,0 +1,11 @@ +# PIXEL LIST descriptor structure + +define LEN_PLSTRUCT 10 + +define PRL_NCOLS Memi[$1] # number of columns +define PRL_NLINES Memi[$1+1] # number of lines +define PRL_LINES Memi[$1+2] # pointer to the line offsets +define PRL_LIST Memi[$1+3] # pointer to list of ranges +define PRL_SZLIST Memi[$1+4] # size of list in INTS +define PRL_LP Memi[$1+5] # offset to next space in list + diff --git a/pkg/images/imfit/src/pixlist.x b/pkg/images/imfit/src/pixlist.x new file mode 100644 index 00000000..066637fd --- /dev/null +++ b/pkg/images/imfit/src/pixlist.x @@ -0,0 +1,369 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "pixlist.h" + +.help pixels xtools "Pixel List Handling Tools" +.nf ________________________________________________________________________ +.fi +.ih +PURPOSE +These routines provide simple pixel list handling facilities and are +intended as a temporary facility pending full scale completion of +image masking. The list is stored in the form of ranges as a function +of line number. Each image line has a offset which may be NULL for +no entry or an offset into the list itself. The actual list is a set of +ranges with the ranges for each line delimited by a NULL. Routines +exist to fetch the ranges for a given line, add or append ranges to a +given line, fetch the next or previous line number with a non-NULL +range and specify whether two lines have the same ranges. At present +the list can grow indefinitely, with additional memory being added as +necessary. No attempt is made to clean up redundant entries though +such a faclity could easily be added. The ranges arguments conform +with the design of the ranges routinesr, with each range consisting +of and intitial and final entry and a step size. A list of ranges +is terminated with a NULL +.ih +PROCEDURE +.nf +prl_init (pl, ncols, nlines) + + pointer pl # pointer to list descriptor + int ncols # number of image columns + int nlines # number of image lines + +nranges = prl_get_ranges (pl, lineno, ranges, max_nranges) + + pointer pl # pointer to list descriptor + int lineno # line number of ranges to be fetched + int ranges[ARB] # ranges to be output + int max_nranges # the maximum number of ranges to be output + +prl_put_ranges (pl, linemin, linemax, ranges) + + pointer pl # pointer to list descriptor + int linemin # minimum line number + int linemax # maximum line number + int ranges[ARB] # ranges to be added to list + +prl_append_ranges (pl, linemin, linemax, ranges) + + pointer pl # pointer to list descriptor + int linemin # minimum line number + int linemax # maximum line number + int ranges[ARB] # ranges to be added to list + +next_lineno/EOF = prl_nextlineno (pl, current_lineno) + + pointer pl # pointer to list descriptor + int current_lineno # current line number + +prev_lineno/EOF = prl_prevlineno (pl, current_lineno) + + pointer pl # pointer to the list descriptor + int current_lineno # current line number + +YES/NO = prl_eqlines (pl, line1, line2) + + pointer pl # pointer to the list descriptor + int line1 # first line number + int line2 # second line number + +prl_free (pl) + + pointer pl # pointer to list descriptor +.fi +.endhelp ________________________________________________________________ + + +# PRL_ADD_RANGES -- Procedure to add the ranges for a given range of +# line numbers to the pixel list. The new ranges will be appended to any +# previously existing ranges for the specified line numbers. + +procedure prl_add_ranges (pl, linemin, linemax, ranges) + +pointer pl # pointer to the list descriptor +int linemin # minimum line number +int linemax # maximum line number +int ranges[ARB] # ranges + +int i, j, lc +int olp, lp, lnull, lold +int nr, nnewr, noldr + +begin + # check conditions + if ((linemin < 1) || (linemax > PRL_NLINES(pl)) || linemin > linemax) + return + + # calculate the length of the range to be appended minus the null + nr = 0 + while (ranges[nr+1] != NULL) + nr = nr + 1 + + + lc = 1 + olp = -1 + do i = linemin, linemax { + + # get offset for line i + lp = Memi[PRL_LINES(pl)+i-1] + + # if line pointer is undefined + if (lp == NULL) { + + if (lc == 1) { + + # set line pointer and store + Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) + lnull = PRL_LP(pl) + + # check the size of the list + if (PRL_SZLIST(pl) < (nr + PRL_LP(pl))) { + PRL_SZLIST(pl) = PRL_SZLIST(pl) + nr + 1 + call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) + } + + # move ranges and reset pointers + call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], nr) + PRL_LP(pl) = PRL_LP(pl) + nr + 1 + Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL + lc = lc + 1 + + } else + + # set line pointer + Memi[PRL_LINES(pl)+i-1] = lnull + + } else { + + if (lp != olp) { + + # set line pointer and store + Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) + lold = PRL_LP(pl) + + # find length of previously defined range and calculate + # length of new ranges + for (j = lp; Memi[PRL_LIST(pl)+j-1] != NULL; j = j + 1) + ; + noldr = j - lp + nnewr = noldr + nr + + # check size of list + if (PRL_SZLIST(pl) < (nnewr + PRL_LP(pl))) { + PRL_SZLIST(pl) = PRL_SZLIST(pl) + nnewr + 1 + call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) + } + + # add ranges to list and update pointers + call amovi (Memi[PRL_LIST(pl)+lp-1], + Memi[PRL_LIST(pl)+PRL_LP(pl)-1], noldr) + PRL_LP(pl) = PRL_LP(pl) + noldr + call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], nr) + PRL_LP(pl) = PRL_LP(pl) + nr + 1 + Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL + + } else + + # set line pointers + Memi[PRL_LINES(pl)+i-1] = lold + + olp = lp + } + } + +end + +# PRL_EQLINES -- Routine to test whether two lines have equal ranges. +# The routine returns YES or NO. + +int procedure prl_eqlines (pl, line1, line2) + +pointer pl # pointer to the list +int line1 # line numbers +int line2 + +begin + if (Memi[PRL_LINES(pl)+line1-1] == Memi[PRL_LINES(pl)+line2-1]) + return (YES) + else + return (NO) +end + +# PRL_GET_RANGES -- Procedure to fetch the ranges for the specified lineno. +# Zero is returned if there are no ranges otherwise the number of ranges +# are returned. The ranges are stored in an integer array. Three positive +# numbers are used to define a range a minimum, maximum and a step size. +# The ranges are delimited by a NULL. + +int procedure prl_get_ranges (pl, lineno, ranges, max_nranges) + +pointer pl # pointer to the pixel list descriptor +int lineno # line number +int ranges[ARB] # array of ranges +int max_nranges # the maximum number of ranges + +int lp, ip +int nranges + +begin + # check for existence of ranges + if (Memi[PRL_LINES(pl)+lineno-1] == NULL) { + ranges[1] = NULL + return (0) + } + + # set pointer to the first element in list for line lineno + lp = PRL_LIST(pl) + Memi[PRL_LINES(pl)+lineno-1] - 1 + + # get ranges + nranges = 0 + ip = 1 + while (Memi[lp+ip-1] != NULL && nranges <= 3 * max_nranges) { + ranges[ip] = Memi[lp+ip-1] + ip = ip + 1 + nranges = nranges + 1 + } + ranges[ip] = NULL + + # return nranges + if (nranges == 0) + return (nranges) + else + return (nranges / 3) +end + +# PRL_NEXTLINENO -- Procedure to fetch the next line number with a set of +# defined ranges given the current line number. Note that the current +# line number is updated. + +int procedure prl_nextlineno (pl, current_lineno) + +pointer pl # pointer to the pixel list descriptor +int current_lineno # current line number + +int findex, lp + +begin + findex = max (1, current_lineno + 1) + do lp = findex, PRL_NLINES(pl) { + if (Memi[PRL_LINES(pl)+lp-1] != NULL) { + current_lineno = lp + return (lp) + } + } + + return (EOF) +end + +# PRL_PREVLINENO -- Procedure to fetch the first previous line number +# with a set of defined ranges given the current line number. +# Note that the current line number is updated. + +int procedure prl_prevlineno (pl, current_lineno) + +pointer pl # pointer to the pixel list descriptor +int current_lineno # current line number + +int findex, lp + +begin + findex = min (current_lineno - 1, PRL_NLINES(pl)) + do lp = findex, 1, -1 { + if (Memi[PRL_LINES(pl)+lp-1] != NULL) { + current_lineno = lp + return (lp) + } + } + + return (EOF) +end + +# PRL_PUT_RANGES -- Procedure to add the ranges for a given range of +# lines to the pixel list. Note that any previously defined ranges are +# lost. + +procedure prl_put_ranges (pl, linemin, linemax, ranges) + +pointer pl # pointer to the list +int linemin # minimum line +int linemax # maximum line +int ranges[ARB] # list of ranges + +int i +int len_range + +begin + # check boundary conditions + if ((linemin < 1) || (linemax > PRL_NLINES(pl)) || (linemin > linemax)) + return + + # determine length of range string minus the NULL + len_range = 0 + while (ranges[len_range+1] != NULL) + len_range = len_range + 1 + + # check space allocation + if (PRL_SZLIST(pl) < (len_range + PRL_LP(pl))) { + PRL_SZLIST(pl) = PRL_SZLIST(pl) + len_range + 1 + call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) + } + + # set the line pointers + do i = linemin, linemax + Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) + + # add ranges + call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], len_range) + PRL_LP(pl) = PRL_LP(pl) + len_range + 1 + Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL +end + + +# PLR_FREE -- Procedure to free the pixel list descriptor + +procedure prl_free (pl) + +pointer pl # pointer to pixel list descriptor + +begin + if (pl == NULL) + return + + if (PRL_LIST(pl) != NULL) + call mfree (PRL_LIST(pl), TY_INT) + if (PRL_LINES(pl) != NULL) + call mfree (PRL_LINES(pl), TY_INT) + + call mfree (pl, TY_STRUCT) +end + +# PRL_INIT -- Procedure to initialize the pixel list. Ncols and nlines are +# the number of columns and lines respectively in the associated IRAF +# image. + +procedure prl_init (pl, ncols, nlines) + +pointer pl # pixel list descriptor +int ncols # number of image columns +int nlines # number of image lines + +begin + # allocate space for a pixel list descriptor + call malloc (pl, LEN_PLSTRUCT, TY_STRUCT) + + # initialize + PRL_NCOLS(pl) = ncols + PRL_NLINES(pl) = nlines + + # allocate space for the line pointers + call malloc (PRL_LINES(pl), PRL_NLINES(pl), TY_INT) + call amovki (NULL, Memi[PRL_LINES(pl)], PRL_NLINES(pl)) + + # set pointer to next free element + PRL_LP(pl) = 1 + + # allocate space for the actual list + call malloc (PRL_LIST(pl), PRL_NLINES(pl), TY_INT) + PRL_SZLIST(pl) = PRL_NLINES(pl) +end diff --git a/pkg/images/imfit/src/ranges.x b/pkg/images/imfit/src/ranges.x new file mode 100644 index 00000000..19dc5c0e --- /dev/null +++ b/pkg/images/imfit/src/ranges.x @@ -0,0 +1,524 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help ranges xtools "Range Parsing Tools" +.ih +PURPOSE + +These tools +parse a string using a syntax to represent integer values, ranges, and +steps. The parsed string is used to generate a list of integers for various +purposes such as specifying lines or columns in an image or tape file numbers. +.ih +SYNTAX + +The syntax for the range string consists of positive integers, '-' (minus), +'x', ',' (comma), and whitespace. The commas and whitespace are ignored +and may be freely used for clarity. The remainder of the string consists +of sequences of five fields. The first field is the beginning of a range, +the second is a '-', the third is the end of the range, the fourth is +a 'x', and the fifth is a step size. Any of the five fields may be +missing causing various default actions. The defaults are illustrated in +the following table. + +.nf +-3x1 A missing starting value defaults to 1. +2-x1 A missing ending value defaults to MAX_INT. +2x1 A missing ending value defaults to MAX_INT. +2-4 A missing step defaults to 1. +4 A missing ending value and step defaults to an ending + value equal to the starting value and a step of 1. +x2 Missing starting and ending values defaults to + the range 1 to MAX_INT with the specified step. +"" The null string is equivalent to "1 - MAX_INT x 1", + i.e all positive integers. +.fi + +The specification of several ranges yields the union of the ranges. +.ih +EXAMPLES + +The following examples further illustrate the range syntax. + +.nf +- All positive integers. +1,5,9 A list of integers equivalent to 1-1x1,5-5x1,9-9x1. +x2 Every second positive integer starting with 1. +2x3 Every third positive integer starting with 2. +-10 All integers between 1 and 10. +5- All integers greater than or equal to 5. +9-3x1 The integers 3,6,9. +.fi +.ih +PROCEDURES + +.ls 4 is_decode_ranges + +.nf +int procedure is_decode_ranges (range_string, ranges, max_ranges, minimum, + maximum, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int minimum, maximum # Minimum and maximum range values allowed +int nvalues # The number of values in the ranges +.fi + +The range string is decoded into an integer array of maximum dimension +3 * max_ranges. Each range consists of three consecutive integers +corresponding to the starting and ending points of the range and the +step size. The number of integers covered by the ranges is returned +as nvalue. The end of the set of ranges is marked by a NULL. +The returned status is either ERR or OK. +.le +.ls 4 is_next_number, is_previous_number + +.nf +int procedure is_next_number (ranges, number) +int procedure is_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter +.fi + +Given a value for number the procedures find the next (previous) number in +increasing (decreasing) +value within the set of ranges. The next (previous) number is returned in +the number argument. A returned status is either OK or EOF. +EOF indicates that there are no greater values. The usual usage would +be in a loop of the form: + +.nf + number = 0 + while (is_next_number (ranges, number) != EOF) { + + } +.fi +.le +.ls 4 is_in_rangelist + +.nf +bool procedure is_in_rangelist (ranges, number) + +int ranges[ARB] # Ranges array +int number # Number to check againts ranges +.fi + +A boolean value is returned indicating whether number is covered by +the ranges. + +.endhelp + + +# IS_DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by a single NULL. + + +int procedure is_decode_ranges (range_string, ranges, max_ranges, minimum, + maximum, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int minimum, maximum # Minimum and maximum range values allowed +int nvalues # The number of values in the ranges + +int ip, nrange, out_of_range, a, b, first, last, step, ctoi() + +begin + ip = 1 + nrange = 1 + nvalues = 0 + out_of_range = 0 + + while (nrange < max_ranges) { + # Default values + a = minimum + b = maximum + step = 1 + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '*', '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + if (out_of_range == 0) { + # Null string defaults + ranges[1, 1] = a + ranges[2, 1] = b + ranges[3, 1] = step + ranges[1, 2] = NULL + nvalues = (b - a) / step + 1 + return (OK) + } else { + # Only out of range data + return (ERR) + } + } else { + ranges[1, nrange] = NULL + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == '*') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, a) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', '*', or 'x' otherwise b = a. + if (range_string[ip] == 'x') + ; + else if ((range_string[ip] == '-') || (range_string[ip] == '*')) { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, b) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + b = a + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == '*') + ; + else + return (ERR) + } + + # Output the range triple. + first = min (a, b) + last = max (a, b) + if (first < minimum) + first = minimum + mod (step - mod (minimum - first, step), step) + if (last > maximum) + last = maximum - mod (last - maximum, step) + if (first <= last) { + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + (last - first) / step + 1 + nrange = nrange + 1 + } else + out_of_range = out_of_range + 1 + } + + return (ERR) # ran out of space +end + + +# IS_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure is_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = ranges[ip] + last = ranges[ip+1] + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure is_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = ranges[ip] + last = ranges[ip+1] + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGELLIST -- Test number to see if it is in range. + +bool procedure is_in_rangelist (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step + +begin + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = ranges[ip] + last = ranges[ip+1] + step = ranges[ip+2] + if (number >= first && number <= last) + if (mod (number - first, step) == 0) + return (TRUE) + } + + return (FALSE) +end + + +# IS_EXPAND_RANGES -- Expand a range string into a array of values. + +int procedure is_expand_ranges (ranges, array, max_nvalues) + +int ranges[ARB] # Range array +int array[max_nvalues] # Array of values +int max_nvalues # Maximum number of values + +int n, value + +int is_next_number() + +begin + n = 0 + value = 0 + while ((n < max_nvalues) && (is_next_number (ranges, value) != EOF)) { + n = n + 1 + array[n] = value + } + + return (n) +end + + +# IS_SELECT_RANGES -- Select array values in the ranges. +# The input and output arrays may be the same. + +procedure is_select_ranges (a, b, ranges) + +real a[ARB] # Input array +real b[ARB] # Output array +int ranges[3, ARB] # Ranges + +int i, j, npts, nmove + +begin + npts = 0 + for (i = 1; ranges[1, i] != NULL; i = i + 1) { + if (ranges[3, i] == 1) { + nmove = ranges[2, i] - ranges[1, i] + 1 + call amovr (a[ranges[1, i]], b[npts + 1], nmove) + npts = npts + nmove + } else { + do j = ranges[1, i], ranges[2, i], ranges[3, i] { + npts = npts + 1 + b[npts] = a[j] + } + } + } +end + + +# IS_CHOOSE_RANGESI -- Copy the selected values from array a to b. + +int procedure is_choose_rangesi (indices, a, b, npts, ifirst, ilast) + +int indices[ARB] # array of indices +int a[ARB] # input array +int b[ARB] # output array +int npts # number of points +int ifirst # first index +int ilast # last index + +int i, element + +begin + element = 1 + do i = 1, npts { + if (indices[i] < ifirst || indices[i] > ilast) + next + b[element] = a[indices[i]] + element = element + 1 + } + return (element - 1) +end + + +# IS_CHOOSE_RANGESR -- Copy the selected values from array a to b. + +int procedure is_choose_rangesr (indices, a, b, npts, ifirst, ilast) + +int indices[ARB] # array of indices +real a[ARB] # input array +real b[ARB] # output array +int npts # number of points +int ifirst # first element to be extracted +int ilast # last element to be extracted + +int i, element + +begin + element = 1 + do i = 1, npts { + if (indices[i] < ifirst || indices[i] > ilast) + next + b[element] = a[indices[i]] + element = element + 1 + } + return (element - 1) +end + + +# IS_MAKE_RANGES -- Procedure to make a set of ranges from an ordered list +# of column numbers. Only a step size of 1 is checked for. + +int procedure is_make_ranges (list, npts, ranges, max_nranges) + +int list[ARB] # list of column numbers in increasing order +int npts # number of list elements +int ranges[ARB] # output ranges +int max_nranges # the maximum number of ranges + +bool next_range +int ip, op, nranges + +begin + # If zero list elements return + if (npts == 0) { + ranges[1] = NULL + return (0) + } + + # Initialize + nranges = 0 + ranges[1] = list[1] + op = 2 + next_range = false + + # Loop over column list + for (ip = 2; ip <= npts && nranges < max_nranges; ip = ip + 1) { + if ((list[ip] != (list[ip-1] + 1))) { + ranges[op] = list[ip-1] + op = op + 1 + ranges[op] = 1 + op = op + 1 + nranges = nranges + 1 + ranges[op] = list[ip] + op = op + 1 + } + } + + # finish off + if (npts == 1) { + ranges[op] = list[npts] + ranges[op+1] = 1 + ranges[op+2] = NULL + nranges = 1 + } else if (nranges == max_nranges) { + ranges[op-1] = NULL + } else { + ranges[op] = list[npts] + ranges[op+1] = 1 + ranges[op+2] = NULL + nranges = nranges + 1 + } + + return (nranges) +end diff --git a/pkg/images/imfit/src/t_imsurfit.x b/pkg/images/imfit/src/t_imsurfit.x new file mode 100644 index 00000000..2a93b8b2 --- /dev/null +++ b/pkg/images/imfit/src/t_imsurfit.x @@ -0,0 +1,400 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imsurfit.h" + +# T_IMSURFIT -- Fit a surface function to an image +# +# 1. A user selected function is fit to each surface. +# 2. Only the selected regions of the image are fit. +# 3. Deviant pixels may be rejected from the fit. +# 4. The user selects the type of output image. The choices are: +# a. the fitted image. +# b. the input image with deviant pixels replaced by +# the fitted values +# c. the input image minus the fitted image. +# d. the ratio of the input image and the fit where +# pixels less than div_min are set to a ratio of 1. + + +procedure t_imsurfit () + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +char image1[SZ_FNAME] # Input image +char image2[SZ_FNAME] # Output image + +char str[SZ_LINE], region_str[SZ_LINE] +int list1, list2, region_type +pointer im1, im2, imfit, gl, sp + +bool clgetb() +int imtopen(), imtgetim(), imtlen(), btoi(), clgeti(), clgwrd() +pointer immap() +real clgetr() + +begin + # Allocate space for imfit structure. + call smark (sp) + call salloc (imfit, LEN_IMSFSTRUCT, TY_STRUCT) + + # Get task parameters. + call clgstr ("input", imtlist1, SZ_FNAME) + call clgstr ("output", imtlist2, SZ_FNAME) + TYPE_OUTPUT(imfit) = clgwrd ("type_output", str, SZ_LINE, + ",fit,clean,residual,response,") + DIV_MIN(imfit) = clgetr ("div_min") + + # Get surface ftting parameters. + SURFACE_TYPE(imfit) = clgwrd ("function", str, SZ_LINE, + ",legendre,chebyshev,spline3,spline1,") + XORDER(imfit) = clgeti ("xorder") + YORDER(imfit) = clgeti ("yorder") + CROSS_TERMS(imfit) = btoi (clgetb ("cross_terms")) + + # Get median processing parameters. + XMEDIAN(imfit) = clgeti ("xmedian") + YMEDIAN(imfit) = clgeti ("ymedian") + MEDIAN_PERCENT(imfit) = clgetr ("median_percent") + if (XMEDIAN(imfit) > 1 || YMEDIAN(imfit) > 1) + MEDIAN(imfit) = YES + else + MEDIAN(imfit) = NO + + # Get rejection cycle parameters. + NITER(imfit) = clgeti ("niter") + LOWER(imfit) = clgetr ("lower") + UPPER(imfit) = clgetr ("upper") + NGROW(imfit) = clgeti ("ngrow") + + if (MEDIAN(IMFIT) == YES) { + REJECT(imfit) = NO + NITER(imfit) = 0 + } else if (NITER(imfit) > 0 && (LOWER(imfit) > 0. || UPPER(imfit) > 0.)) + REJECT(imfit) = YES + else { + REJECT(imfit) = NO + NITER(imfit) = 0 + } + + # Checking sigmas for cleaning. + if (TYPE_OUTPUT(imfit) == CLEAN && MEDIAN(imfit) == YES) + call error (0, + "T_IMSURFIT: Clean option and median processing are exclusive.") + if (TYPE_OUTPUT(imfit) == CLEAN && NITER(imfit) <= 0) + call error (0, "T_IMSURFIT: Clean option requires non-zero niter.") + if (TYPE_OUTPUT(imfit) == CLEAN && LOWER(imfit) <= 0. && + UPPER(imfit) <= 0.) + call error (0, "T_IMSURFIT: Clean option requires non-zero sigma.") + + # Get regions to be fit. + gl = NULL + region_type = clgwrd ("regions", str, SZ_LINE, + ",all,columns,rows,border,sections,circle,invcircle,") + switch (region_type) { + case ALL: + ; + case BORDER: + call clgstr ("border", region_str, SZ_LINE) + case SECTIONS: + call clgstr ("sections", region_str, SZ_LINE) + case COLUMNS: + call clgstr ("columns", region_str, SZ_LINE) + case ROWS: + call clgstr ("rows", region_str, SZ_LINE) + case CIRCLE, INVCIRCLE: + call clgstr ("circle", region_str, SZ_LINE) + } + + # Expand the input and output image lists. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Do each set of input and output images. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + iferr { + if (region_type != ALL) + call make_good_list (im1, gl, region_type, region_str) + call imsurfit (im1, im2, imfit, gl) + } then + call erract (EA_WARN) + + call imunmap (im1) + call imunmap (im2) + call prl_free (gl) + } + + # Cleanup. + call sfree (sp) + call imtclose (list1) + call imtclose (list2) +end + + +# MAKE_GOOD_LIST -- Procedure to make a list of good regions. The program +# returns an error message if no good regions are defined. The good +# list parameter is set to NULL if the whole image is to be fit. This routine +# uses both the ranges and pixlist package which will be replaced by image +# masking. + +procedure make_good_list (im, gl, region_type, region_string) + +pointer im # pointer to the image +pointer gl # good pixel list descriptor +int region_type # type of good region +char region_string[ARB] # region parameters + +int i, ip, zero, nvals, range_min, r2, xdist, max_nranges +int x1, x2, y1, y2, temp, border, xcenter, ycenter, radius +int columns[7] +pointer sp, ranges, list + +bool is_in_rangelist() +int is_next_number(), is_decode_ranges(), open(), fscan(), nscan(), ctoi() +errchk open, close + +begin + # Determine the maximum number of images. + max_nranges = IM_LEN(im,1) + + # Allocate working space. + call smark (sp) + call salloc (ranges, 3 * max_nranges + 1, TY_INT) + + # Compute the good pixel list. + switch (region_type) { + case ROWS: + + # Decode the row ranges. + if (is_decode_ranges (region_string, Memi[ranges], max_nranges, 1, + int (IM_LEN(im,2)), nvals) == ERR) + call error (0, "MAKE_GOOD_LIST: Error decoding row string.") + if (nvals == 0) + call error (0, "MAKE_GOOD_LIST: no good rows.") + if (nvals == IM_LEN(im,2)) { + call sfree (sp) + return + } + + # Intialize the good pixel list. + call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) + + # Set column limits using the ranges format. + columns[1] = 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + + # Set column limits for the specied lines. + zero = 0 + range_min = is_next_number (Memi[ranges], zero) + while (range_min != EOF) { + for (i = range_min; i <= IM_LEN(im,2) + 1; i = i + 1) { + if (!is_in_rangelist (Memi[ranges], i) || + i == IM_LEN(im,2)+1) { + call prl_put_ranges (gl, range_min, i-1, columns) + break + } + } + range_min = is_next_number (Memi[ranges], i) + } + + case COLUMNS: + + # Set the specified columns. + if (is_decode_ranges (region_string, Memi[ranges], max_nranges, 1, + int (IM_LEN(im,1)), nvals) == ERR) + call error (0, "MAKE_GOOD_LIST: Error decoding column string.") + if (nvals == 0) + call error (0, "MAKE_GOOD_LIST: No good columns.") + if (nvals == IM_LEN(im,1)) { + call sfree (sp) + return + } + + # Make the good pixel list. + call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) + call prl_add_ranges (gl, 1, int (IM_LEN(im,2)), Memi[ranges]) + + case CIRCLE, INVCIRCLE: + + # Get the parameters of the circle. + ip = 1 + if (ctoi (region_string, ip, xcenter) <= 0) + call error (0, "MAKE_GOOD_LIST: Error decoding xcenter.") + if (ctoi (region_string, ip, ycenter) <= 0) + call error (0, "MAKE_GOOD_LIST: Error decoding ycenter.") + if (ctoi (region_string, ip, radius) <= 0) + call error (0, "MAKE_GOOD_LIST: Error decoding radius.") + + y1 = max (1, ycenter - radius) + y2 = min (int (IM_LEN(im,2)), ycenter + radius) + x1 = max (1, xcenter - radius) + x2 = min (int (IM_LEN(im,1)), xcenter + radius) + if (region_type == CIRCLE) { + if (y1 > IM_LEN(im,2) || y2 < 1 || x1 > IM_LEN(im,1) || x2 < 1) + call error (0, "MAKE_GOOD_LIST: No good regions.") + } + + # Create the good pixel list. + call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) + + r2 = radius ** 2 + if (region_type == CIRCLE) { + do i = y1, y2 { + xdist = sqrt (real (r2 - (ycenter - i) ** 2)) + x1 = max (1, xcenter - xdist) + x2 = min (IM_LEN(im,1), xcenter + xdist) + columns[1] = x1 + columns[2] = x2 + columns[3] = 1 + columns[4] = NULL + call prl_put_ranges (gl, i, i, columns) + } + } else if (region_type == INVCIRCLE) { + do i = 1, y1 - 1 { + columns[1] = 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + call prl_put_ranges (gl, i, i, columns) + } + do i = y2 + 1, IM_LEN(im,2) { + columns[1] = 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + call prl_put_ranges (gl, i, i, columns) + } + do i = y1, y2 { + xdist = sqrt (real (r2 - (ycenter - i) ** 2)) + x1 = max (1, xcenter - xdist) + x2 = min (IM_LEN(im,1), xcenter + xdist) + if (x1 > 1) { + columns[1] = 1 + columns[2] = x1 - 1 + columns[3] = 1 + if (x2 < IM_LEN(im,1)) { + columns[4] = x2 + 1 + columns[5] = IM_LEN(im,1) + columns[6] = 1 + columns[7] = NULL + } else + columns[4] = NULL + } else if (x2 < IM_LEN(im,1)) { + columns[1] = x2 + 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + } else + columns[1] = NULL + call prl_put_ranges (gl, i, i, columns) + } + } + + + case SECTIONS: + + # Open file of sections. + list = open (region_string, READ_ONLY, TEXT_FILE) + call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) + + # Scan the list. + while (fscan (list) != EOF) { + + # Fetch parameters from list. + call gargi (x1) + call gargi (x2) + call gargi (y1) + call gargi (y2) + if (nscan() != 4) + next + + # Check and correct for out of bounds limits. + x1 = max (1, min (IM_LEN(im,1), x1)) + x2 = min (IM_LEN(im,1), max (1, x2)) + y1 = max (1, min (IM_LEN(im,2), y1)) + y2 = min (IM_LEN(im,2), max (1, y2)) + + # Check the order. + if (x2 < x1) { + temp = x1 + x1 = x2 + x2 = temp + } + if (y2 < y1) { + temp = y1 + y1 = y2 + y2 = temp + } + + # If entire image return. + if ((x1 == 1) && (x2 == IM_LEN(im,1)) && (y1 == 1) && + (y2 == IM_LEN(im,2))) { + call prl_free (gl) + gl = NULL + break + } + + # Set ranges. + columns[1] = x1 + columns[2] = x2 + columns[3] = 1 + columns[4] = NULL + call prl_add_ranges (gl, y1, y2, columns) + } + + call close (list) + + case BORDER: + + # Decode border parameter. + ip = 1 + if (ctoi (region_string, ip, border) == ERR) + call error (0, "MAKE_GOOD_LIST: Error decoding border string.") + if (border < 1) + call error (0, "MAKE_GOOD_LIST: No border.") + if ((border > IM_LEN(im,1)/2) && (border > IM_LEN(im,2)/2)) { + call sfree (sp) + return + } + + # Intialize list. + call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) + y1 = 1 + border - 1 + y2 = IM_LEN(im,2) - border + 1 + columns[1] = 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + + # Set ranges for top and bottom edges of image. + call prl_put_ranges (gl, 1, y1, columns) + call prl_put_ranges (gl, y2, int (IM_LEN(im,2)), columns) + + columns[1] = 1 + columns[2] = y1 + columns[3] = 1 + columns[4] = NULL + call prl_put_ranges (gl, y1 + 1, y2 - 1, columns) + + columns[1] = IM_LEN(im,1) - border + 1 + columns[2] = IM_LEN(im,1) + columns[3] = 1 + columns[4] = NULL + call prl_add_ranges (gl, y1 + 1, y2 - 1, columns) + } + + call sfree (sp) +end diff --git a/pkg/images/imfit/src/t_lineclean.x b/pkg/images/imfit/src/t_lineclean.x new file mode 100644 index 00000000..4acb9752 --- /dev/null +++ b/pkg/images/imfit/src/t_lineclean.x @@ -0,0 +1,270 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# LINECLEAN -- Fit a function to the image lines and output an image +# with rejected points replaced by the fit. The fitting parameters may be +# set interactively using the icfit package. + +procedure t_lineclean () + +int listin # Input image list +int listout # Output image list +char sample[SZ_LINE] # Sample ranges +int naverage # Sample averaging size +char function[SZ_LINE] # Curve fitting function +int order # Order of curve fitting function +real low_reject, high_reject # Rejection threshold +int niterate # Number of rejection iterations +real grow # Rejection growing radius +bool interactive # Interactive? + +char input[SZ_LINE] # Input image +char output[SZ_FNAME] # Output image +pointer in, out # IMIO pointers +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer + +int imtopen(), imtgetim(), imtlen(), gt_init() +int clgeti() +real clgetr() +bool clgetb() + +begin + # Get input and output lists and check that the number of images + # are the same. + + call clgstr ("input", input, SZ_LINE) + listin = imtopen (input) + call clgstr ("output", input, SZ_LINE) + listout = imtopen (input) + if (imtlen (listin) != imtlen (listout)) { + call imtclose (listin) + call imtclose (listout) + call error (0, "Input and output image lists do not match") + } + + # Get task parameters. + + call clgstr ("sample", sample, SZ_LINE) + naverage = clgeti ("naverage") + call clgstr ("function", function, SZ_LINE) + order = clgeti ("order") + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + niterate = clgeti ("niterate") + grow = clgetr ("grow") + interactive = clgetb ("interactive") + + + # Set the ICFIT pointer structure. + call ic_open (ic) + call ic_pstr (ic, "sample", sample) + call ic_puti (ic, "naverage", naverage) + call ic_pstr (ic, "function", function) + call ic_puti (ic, "order", order) + call ic_putr (ic, "low", low_reject) + call ic_putr (ic, "high", high_reject) + call ic_puti (ic, "niterate", niterate) + call ic_putr (ic, "grow", grow) + call ic_pstr (ic, "ylabel", "") + + gt = gt_init() + call gt_sets (gt, GTTYPE, "line") + + # Clean the lines in each input image. + + while ((imtgetim (listin, input, SZ_FNAME) != EOF) && + (imtgetim (listout, output, SZ_FNAME) != EOF)) { + + call lc_immap (input, output, in, out) + call lineclean (in, out, ic, gt, input, interactive) + call imunmap (in) + call imunmap (out) + } + + call ic_closer (ic) + call gt_free (gt) + call imtclose (listin) + call imtclose (listout) +end + + +# LINECLEAN -- Given the image descriptor determine the fitting function +# for each line and create an output image. If the interactive flag +# is set then set the fitting parameters interactively. + +procedure lineclean (in, out, ic, gt, title, interactive) + +pointer in # IMIO pointer for input image +pointer out # IMIO pointer for output image +pointer ic # ICFIT pointer +pointer gt # GTIO pointer +char title[ARB] # Title +bool interactive # Interactive? + +char graphics[SZ_FNAME] +int i, nx, new +long inline[IM_MAXDIM], outline[IM_MAXDIM] +pointer cv, gp, sp, x, wts, indata, outdata + +int lf_getline(), imgnlr(), impnlr(), strlen() +pointer gopen() + +begin + # Allocate memory for curve fitting. + + nx = IM_LEN(in, 1) + + call smark (sp) + call salloc (x, nx, TY_REAL) + call salloc (wts, nx, TY_REAL) + + do i = 1, nx + Memr[x+i-1] = i + call amovkr (1., Memr[wts], nx) + + call ic_putr (ic, "xmin", Memr[x]) + call ic_putr (ic, "xmax", Memr[x+nx-1]) + + # If the interactive flag is set then use icg_fit to set the + # fitting parameters. Get_fitline returns EOF when the user + # is done. The weights are reset since the user may delete + # points. + + if (interactive) { + call clgstr ("graphics", graphics, SZ_FNAME) + gp = gopen ("stdgraph", NEW_FILE, STDGRAPH) + + i = strlen (title) + while (lf_getline (ic, gt, in, indata, inline, title)!=EOF) { + title[i + 1] = EOS + call icg_fit (ic, gp, "cursor", gt, cv, Memr[x], Memr[indata], + Memr[wts], nx) + call amovkr (1., Memr[wts], nx) + } + call gclose (gp) + } + + # Loop through each input image line and create an output image line. + + new = YES + call amovkl (long(1), inline, IM_MAXDIM) + call amovkl (long(1), outline, IM_MAXDIM) + + while (imgnlr (in, indata, inline) != EOF) { + if (impnlr (out, outdata, outline) == EOF) + call error (0, "Error writing output image") + + call ic_fit (ic, cv, Memr[x], Memr[indata], Memr[wts], + nx, new, YES, new, new) + new = NO + + call ic_clean (ic, cv, Memr[x], Memr[indata], Memr[wts], nx) + + call amovr (Memr[indata], Memr[outdata], nx) + } + + call cvfree (cv) + call sfree (sp) +end + + +# LC_IMMAP -- Map images for lineclean. + +procedure lc_immap (input, output, in, out) + +char input[ARB] # Input image +char output[ARB] # Output image +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer + +pointer sp, root, sect +int imaccess() +pointer immap() + +begin + # Get the root name and section of the input image. + + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (sect, SZ_FNAME, TY_CHAR) + + call get_root (input, Memc[root], SZ_FNAME) + call get_section (input, Memc[sect], SZ_FNAME) + + # If the output image is not accessible then create it as a new copy + # of the full input image. + + if (imaccess (output, 0) == NO) + call img_imcopy (Memc[root], output, false) + + # Map the input and output images. + + in = immap (input, READ_ONLY, 0) + + call sprintf (Memc[root], SZ_FNAME, "%s%s") + call pargstr (output) + call pargstr (Memc[sect]) + out = immap (Memc[root], READ_WRITE, 0) + + call sfree (sp) +end + + +# LF_GETLINE -- Get an image line to be fit interactively. Return EOF +# when the user enters EOF or CR. Default line is the first line and +# the out of bounds lines are silently limited to the nearest in bounds line. + +int procedure lf_getline (ic, gt, im, data, v, title) + +pointer ic # ICFIT pointer +pointer gt # GTOOLS pointer +pointer im # IMIO pointer +pointer data # Image data +long v[ARB] # Image line vector +char title[ARB] # Title + +int i +char line[SZ_LINE] +int getline(), nscan(), imgnlr() + +begin + call sprintf (title, SZ_LINE, "%s: Fit line =") + call pargstr (title) + + call printf ("%s ") + call pargstr (title) + call flush (STDOUT) + + if (getline(STDIN, line) == EOF) + return (EOF) + call sscan (line) + + call amovkl (long (1), v, IM_MAXDIM) + do i = 2, max (2, IM_NDIM(im)) { + call gargl (v[i]) + if (nscan() == 0) + return (EOF) + else if (nscan() != i - 1) + break + + if (IM_NDIM(im) == 1) + v[i] = 1 + else + v[i] = max (1, min (IM_LEN(im, i), v[i])) + + call sprintf (title, SZ_LINE, "%s %d") + call pargstr (title) + call pargl (v[i]) + } + + call sprintf (title, SZ_LINE, "%s\n%s") + call pargstr (title) + call pargstr (IM_TITLE(im)) + call ic_pstr (ic, "xlabel", "Column") + call gt_sets (gt, GTTITLE, title) + + return (imgnlr (im, data, v)) +end diff --git a/pkg/images/imgeom/Revisions b/pkg/images/imgeom/Revisions new file mode 100644 index 00000000..5e4ad630 --- /dev/null +++ b/pkg/images/imgeom/Revisions @@ -0,0 +1,2026 @@ +.help revisions Jan97 images.imgeom +.nf + +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/imgeom/blkavg.par b/pkg/images/imgeom/blkavg.par new file mode 100644 index 00000000..eb5f1d82 --- /dev/null +++ b/pkg/images/imgeom/blkavg.par @@ -0,0 +1,12 @@ +# BLKAVG -- Block average or sum on n-dimensional images. + +input,s,a,,,,Input images +output,s,a,,,,Output block averaged images +option,s,h,average,"average|sum",,Type of operation +b1,i,a,1,1,,blocking factor in dimension 1 (x or column) +b2,i,a,1,1,,blocking factor in dimension 2 (y or line) +b3,i,a,1,1,,blocking factor in dimension 3 (z or band) +b4,i,a,1,1,,blocking factor in dimension 4 +b5,i,a,1,1,,blocking factor in dimension 5 +b6,i,a,1,1,,blocking factor in dimension 6 +b7,i,a,1,1,,blocking factor in dimension 7 diff --git a/pkg/images/imgeom/blkrep.par b/pkg/images/imgeom/blkrep.par new file mode 100644 index 00000000..befcc002 --- /dev/null +++ b/pkg/images/imgeom/blkrep.par @@ -0,0 +1,11 @@ +# BLKREP -- Block replicate an n-dimensional images. + +input,s,a,,,,Input images +output,s,a,,,,Output block replicated images +b1,i,a,1,1,,block replication factor in dimension 1 (x or column) +b2,i,a,1,1,,block replication factor in dimension 2 (y or line) +b3,i,a,1,1,,block replication factor in dimension 3 (z or band) +b4,i,a,1,1,,block replication factor in dimension 4 +b5,i,a,1,1,,block replication factor in dimension 5 +b6,i,a,1,1,,block replication factor in dimension 6 +b7,i,a,1,1,,block replication factor in dimension 7 diff --git a/pkg/images/imgeom/doc/blkavg.hlp b/pkg/images/imgeom/doc/blkavg.hlp new file mode 100644 index 00000000..c4491788 --- /dev/null +++ b/pkg/images/imgeom/doc/blkavg.hlp @@ -0,0 +1,65 @@ +.help blkavg Oct85 images.imgeom +.ih +NAME +blkavg -- block average or sum n-dimensional images +.ih +USAGE +.nf +blkavg input output b1 b2 b3 b4 b5 b6 b7 +.fi +.ih +PARAMETERS +.ls input +List of images to be block averaged. Image sections are allowed. +.le +.ls output +List of output image names. If the output image name is the same as the input +image name then the block averaged image replaces the input image. +.le +.ls b1 +The number of columns to be block averaged (dimension 1, or x). +.le +.ls b2 +The number of lines to be block averaged (dimension 2, or y). +.le +.ls b3 +The number of bands to be block averaged (dimension 3, or z). +.le +.ls b4 +The number of pixels to be block averaged in dimension 4 (... etc. for b5-b7). +.le +.ls option = "average" +Type of block average. The choices are "average" and "sum". +.le +.ih +DESCRIPTION +The list of input images are block averaged or summed to form the output images. +The output image names are specified by the output list. The number of +output image names must be the same as the number of input images. +An output image name may be the same +as the corresponding input image in which case the block averaged image replaces +the input image. The last column, line, etc. of the output image may be +a partial block. The option parameter selects whether to block average +or block sum. +.ih +TIMINGS +It requires approximately 10 cpu seconds to block average a 512 by 512 +short image by a factor of 8 in each direction (Vax 11/750 with fpa). +.ih +EXAMPLES +1. To block average a 2-d image in blocks of 2 by 3: + + cl> blkavg imagein imageout 2 3 + +2. To block sum two 2-d images in blocks of 5 by 5: + + cl> blkavg image1,image2 out1,out2 5 5 op=sum + +3. To block average a 3-d image by 4 in x and y and 2 in z: + + cl> blkavg imagein imageout 4 4 2 + + or + + cl> blkavg imagein imageout b1=4 b2=4 b3=2 +.endhelp diff --git a/pkg/images/imgeom/doc/blkrep.hlp b/pkg/images/imgeom/doc/blkrep.hlp new file mode 100644 index 00000000..7f72616b --- /dev/null +++ b/pkg/images/imgeom/doc/blkrep.hlp @@ -0,0 +1,103 @@ +.help blkrep Sep86 images.imgeom +.ih +NAME +blkrep -- block replicate n-dimensional images +.ih +USAGE +.nf +blkrep input output b1 [b2 b3 b4 b5 b6 b7] +.fi +.ih +PARAMETERS +.ls input +List of images to be block replicated. Image sections are allowed. +.le +.ls output +List of output image names. If the output image name is the same as the input +image name then the block replicated image replaces the input image. +.le +.ls b1, b2, b3, b4, b5, b6, b7 +Block replication factor for dimensions 1 - 7. Only the block factors for +the dimensions of the input image are required. Dimension 1 is the column +or x axis, dimension 2 is the line or y axis. +.le +.ih +DESCRIPTION +The list of input images are block replicated by the specified factors +to form the output images. The output image names are specified by the +output list. The number of output image names must be the same as the +number of input images. An output image name may be the same as the +corresponding input image in which case the block averaged image +replaces the input image. Only the block factors for the dimensions +of the input images are used. + +This task is a complement to \fBblkavg\fR which block averages or sums +images. Another related task is \fBmagnify\fR which interpolates +images to arbitrary sizes. This task, however, is only applicable to +two dimensional images with at least two pixels in each dimension. +Finally, in conjunction with \fBimstack\fR a lower dimensional image +can be replicated to higher dimensions. +.ih +TIMINGS +VAX 11/750 with FPA running UNIX 4.3BSD and IRAF V2.4: + +.nf + SIZE DATATYPE REPLICATION CPU CLOCK + 100 short 5 0.5s 1s + 100 real 5 0.5s 1s + 100x100 short 5x5 1.7s 5s + 100x100 real 5x5 2.1s 6s + 100x100x1 real 5x5x5 9.7s 33s +.fi +.ih +EXAMPLES +.ls 4 1. +To block replicate a 1D image in blocks of 3: + +cl> blkrep imagein imageout 3 +.le +.ls 4 2. +To block replicate a 2D image in blocks of 2 by 3: + +cl> blkrep imagein imageout 2 3 +.le +.ls 4 3. +To block replicate two 2D images in blocks of 5 by 5: + +cl> blkrep image1,image2 out1,out2 5 5 +.le +.ls 4 4. +To block replicate a 3D image in place by factors of 2: + +cl> blkrep image1 image1 2 2 2 +.le +.ls 4 5. +To smooth an image by block averaging and expanding by a factor of 2: + +.nf +cl> blkavg imagein imageout 2 2 +cl> blkrep imageout imageout 2 2 +.fi +.le +.ls 4 6. +To take a 1D image and create a 2D image in which each line is the same: + +.nf +cl> imstack image1d image2d +cl> blkrep image2d image2d 1 100 +.fi +.le +.ls 4 7. +To take a 1D image and create a 2D image in which each column is the same: + +.nf +cl> imstack image1d image2d +cl> imtranspose image2d image2d +cl> blkrep image2d image2d 100 1 +.fi +.le + +.ih +SEE ALSO +blkavg, imstack, magnify +.endhelp diff --git a/pkg/images/imgeom/doc/im3dtran.hlp b/pkg/images/imgeom/doc/im3dtran.hlp new file mode 100644 index 00000000..68a2b0cd --- /dev/null +++ b/pkg/images/imgeom/doc/im3dtran.hlp @@ -0,0 +1,94 @@ +.help im3dtran Jan97 images.imgeom +.ih +NAME +im3dtran -- Transpose a 3D image +.ih +USAGE +im3dtran input output +.ih +PARAMETERS +.ls input +The input 3d image. +.le +.ls output +The output transposed 3D image. If the output image name is the same as +the input image name then the original image will be overwritten. The number +of output images must equal the number of input images. +.le +.ls new_x = 3 +The new x axis. The default (3) replaces new x with old z. +.le +.ls new_y = 2 +The new y axis = old axis. The default (2) does not change the y axis. +.le +.ls new_z = 1 +The new z axis. The default (1) replaces new z with old x. +.le +.ls len_blk = 128 +The size in pixels of the linear internal subraster. Im3dtran will try to +transpose a subraster up to len_blk cubed at one time. Runtime is much +faster with larger \fBlen_blk\fR, but the task may run out of memory. +.le +.ls verbose = yes +Print messages about actions taken by the task. +.le + +.ih +DESCRIPTION + +IM3DTRAN transposes the input images \fIinput\fR in 3 dimensions and +writes the transposed images to \fIoutput\fR. The 6 possible axis +mappings are specified by setting the parameters \fInew_x\fR, \fInew_y\fR, +and \fInew_z\fR. + +IM3DTRAN can be used to rotate a datacube 90 degrees in any direction by +combining the transpose operation with an axis flip. For +example, Consider a datacube is visualized with its origin at the lower +left front +when seen by the viewer, with its abscissa being the x axis, its ordinate +the y axis, and its depth the z axis, with z increasing away from the viewer +or into the datacube [this +is a left-handed coordinate system]. To rotate the datacube +by 90 degrees clockwise about the y axis when viewed from the +y direction; +the old z axis must become the new x axis, and the old x axis must become +the new z axis, while the new y axis remains old y axis. In this case the +axis that must be flipped prior to transposition is the x axis as shown +in example 2. + +The parameter \fBlen_blk\fR controls how much memory is used during the +transpose operation. \fBlen_blk\fR elements are used in each axis at a +time, or a cube len_blk elements on a side. If \fBlen_blk\fR is too large, +the task will abort with an "out of memory" error. If it is too small, +the task can take a very long time to run. The maximum size of len_blk +depends on how much memory is available at the time IM3DTRAN is run, +and the size and datatype of the image to be transposed. + +.ih +EXAMPLES + +1. Transpose axes 1 2 and 3 of a list of input images to axes 2 1 and 3 of +a list of output images. + +.nf + cl> im3dtran image1,image2,image3 tr1,tr2,tr3 2 1 3 +.fi + +2. For an input datacube with columns = x = abscissa, lines = y = ordinate, +and bands = z = depth increasing away from viewer, and with the image +origin at the lower left front, rotate datacube 90 degrees clockwise +around the y axis when viewed from +y (top): + +.nf + cl> im3dtran input[-*,*,*] output 3 2 1 +.fi + +.ih +TIMINGS + +.ih +BUGS + +.ih +SEE ALSO +imtranspose, imjoin, imstack, imslice +.endhelp diff --git a/pkg/images/imgeom/doc/imlintran.hlp b/pkg/images/imgeom/doc/imlintran.hlp new file mode 100644 index 00000000..f595ffda --- /dev/null +++ b/pkg/images/imgeom/doc/imlintran.hlp @@ -0,0 +1,184 @@ +.help imlintran Dec98 images.imgeom +.ih +NAME +imlintran -- shift, scale, rotate a list of images +.ih +USAGE +imlintran input output xrotation yrotation xmag ymag +.ih +PARAMETERS +.ls input +List of images to be transformed. +.le +.ls output +List of output images. +.le +.ls xrotation, yrotation +Angle of rotation of points on the image axes in degrees. +Positive angles rotate in a counter-clockwise sense around the x axis. +For a normal coordinate axes rotation xrotation and yrotation should +be the same. A simple y axis flip can be introduced by make yrotation +equal to xrotation plus 180 degrees. An axis skew can be introduced by +making the angle between xrotation and yrotation other than a +multiple of 90 degrees. +.le +.ls xmag, ymag +The number of input pixels per output pixel in x and y. The magnifications +must always be positive numbers. Numbers less than 1 magnify the image; +numbers greater than one reduce the image. +.le +.ls xin = INDEF, yin = INDEF +The origin of the input picture in pixels. Xin and yin default to the center of +the input image. +.le +.ls xout = INDEF, yout = INDEF +The origin of the output image. Xout and yout default to the center of the +output image. +.le +.ls ncols = INDEF, nlines = INDEF +The number of columns and rows in the output image. The default is to +keep the dimensions the same as the input image. If ncols and nrows are +less than or equal to zero then the task computes the number of rows and +columns required to include the whole input image, excluding the effects +of any origin shift. +.le +.ls interpolant = "linear" +The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order interior polynomial in x and y. +.le +.ls poly5 +Fifth order interior polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate value by reflecting about the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The value of the constant for boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux? +.le +.ls nxblock = 512, nyblock = 512 +If the size of the output image is less than nxblock by nyblock then +the entire image is transformed at once. Otherwise the output image +is computed in blocks of nxblock by nxblock pixels. +.le +.ih +DESCRIPTION + +IMLINTRAN linearly transforms a the list of images in input using rotation +angles and magnification factors supplied by the user and writes the output +images into output. The coordinate transformation from input to output +image is described below. + +.nf + 1. subtract the origin + + xt = x(input) - xin + yt = y(input) - yin + + 2. scale the image + + xt = xt / xmag + yt = xt / xmag + + 3. rotate the image + + xt = xt * cos (xrotation) - yt * sin (yrotation) + yt = xt * sin (yrotation) + yt * cos (yrotation) + + 4. new orgin + + x(output) = xt + xout + y(output) = yt + yout + +.fi + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels using the inverse +of the above transformation. +IMLINTRAN uses the routines in the 2-D interpolation package. + +.ih +TIMINGS +It requires approximately 70 and 290 cpu seconds respectively to linearly +transform a 512 by 512 real image using bilinear and biquintic +interpolation respectively (Vax 11/750 fpa). + +.ih +EXAMPLES + +.nf +1. Rotate an image 45 degrees around its center and magnify + the image by a factor of 2. in each direction. + + cl> imlintran n4151 n4151rm 45.0 45.0 0.50 0.50 + +2. Rotate the axes of an image by 45 degrees around 100. and 100., + shift the orgin to 150. and 150. and flip the y axis. + + cl> imlintran n1068 n1068r 45.0 225.0 1.0 1.0 xin=100. yin=100. \ + >>> xout=150. yout=150. + +3. Rotate an image by 45 degrees and reduce the scale in x and y + by a factor of 1.5 + + cl> imlintran n7026 n7026rm 45.0 45.0 1.5 1.5 +.fi + +.ih +BUGS +.ih +SEE ALSO +imshift, magnify, rotate, lintran, register, geotran, geomap +.endhelp diff --git a/pkg/images/imgeom/doc/imshift.hlp b/pkg/images/imgeom/doc/imshift.hlp new file mode 100644 index 00000000..5d3b3dd5 --- /dev/null +++ b/pkg/images/imgeom/doc/imshift.hlp @@ -0,0 +1,125 @@ +.help imshift Dec98 images.imgeom +.ih +NAME +imshift -- shift a set of images in x and y +.ih +USAGE +imshift input output xshift yshift +.ih +PARAMETERS +.ls input +List of images to be transformed. +.le +.ls output +List of output images. +.le +.ls xshift, yshift +Fractional pixel shift in x and y such that xout = xin + xshift and +yout = yin + yshift. +.le +.ls shifts_file = "" +The name of the text file containing the shifts for each input image. If no +file name is supplied each input image is shifted by \fIxshift\fR and +\fIyshift\fR. Shifts are listed in the text file, 1 set of shifts per image, +with the x and y shift in columns 1 and 2 respectively. The number of +shifts in the file must equal the number of input images. +.le +.ls interp_type = "linear" +The interpolant type use to computed the output shifted image. +The choices are the following: +.ls nearest +nearest neighbor. +.le +.ls linear +bilinear interpolation in x and y. +.le +.ls poly3 +third order interior polynomial in x and y. +.le +.ls poly5 +fifth order interior polynomial in x and y. +.le +.ls spline3 +bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width input by the +user will be rounded up to the nearest odd number. The default sinc width +is 31 by 31. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fractions in x and y +by appending values between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. The +value 0.0 is increased to 0.001. Drizzle resampling with a pixel fraction +of 1.0 in x and y is identical to bilinear interpolation. +.le +.le +.ls boundary_type = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate value by reflecting about the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ih +DESCRIPTION + +IMSHIFT will shift an image in x and y such that: + +.nf + xout = xin + xshift + yout = yin + yshift + +.fi + +The output image gray levels are determined by interpolating in the input +image at the positions of the shifted output pixels. +IMSHIFT uses the routines in the 2-D interpolator package. + +.ih +EXAMPLES + +1. Shift an image by (+3.2, -4.5) using a biquintic interior polynomial + interpolant and boundary extension. + + cl> imshift vys70 vys70shift 3.2 -4.5 inter=poly5 bound=neare + +2. Shift an image by (-6., 1.2) using bilinear interpolation and + boundary extension. + + cl> imshift ugc1040 ugc1040shift -6.0 1.2 bound=neare + +3. Shift a set of images using shifts listed in the textfile "shifts". + + cl> page shifts + + 3.5 4.86 + -2. 8.9 + 10.1 7.8 + + cl> imshift im1,im2,im3 im1.s,im2.s,im3.s shifts_file=shifts + +.ih +TIMINGS +The time required to shift a 512 by 512 real image by fractional pixel +amounts in x and y is approximately 10, 20, 70, 120, and 120 cpu seconds for the +nearest neighbor, bilinear, bicubic, biquintic and bicubic spline +interpolants respectively (Vax 11/750 fpa). + +.ih +BUGS +.ih +SEE ALSO +shiftlines, magnify, rotate, geomap, geotran, imlintran +.endhelp diff --git a/pkg/images/imgeom/doc/imtrans.hlp b/pkg/images/imgeom/doc/imtrans.hlp new file mode 100644 index 00000000..332cf040 --- /dev/null +++ b/pkg/images/imgeom/doc/imtrans.hlp @@ -0,0 +1,69 @@ +.help imtranspose Aug84 images.imgeom +.ih +NAME +imtranspose -- transpose two dimensional images +.ih +USAGE +.nf +imtranspose input output +.fi +.ih +PARAMETERS +.ls input +List of images to be transposed. +.le +.ls output +List of output transposed images. If the output image name is the same as +the input image name then the output image will replace the input image. +The number of output images must be the same as the number of input images. +.le +.ls len_blk = 512 +The one dimensional length of the transpose blocks. +.le +.ih +DESCRIPTION +Imtranspose transposes the list of images in input by interchanging +their rows and columns and writing the results to images specified in +output. The number of input and output images must be the same. + +The transpose is done in square blocks whose dimensions are equal \fIlen_blk\fR. + +The imtranspose tasks can be used to perform counter-clockwise or +clockwise ninety degree rotations by flipping the y or x axis respectively +in the input image section specification. + +.ih +EXAMPLES +1. To transpose an image: + + cl> imtranspose image1 image2 + +2. To transpose an image in place: + + cl> imtranspose image1 image1 + +3. To rotate an image 90 degrees counter-clockwise and clockwise: + + cl> imtranspose image1[*,-*] image2 + + cl> imtranspose image1[-*,*] image2 + +3. To transpose a set of 3 images listed 1 per line in the file imlist to +the new images trans001, trans002, and trans003: + + cl> imtranspose @imlist trans001,trans002,trans003 + +4. To transpose a set of images in place: + + cl> imtranspose frame* frame* + +5. To rotate an image 90 degrees counter-clockwise in place: + + cl> imtranspose image[*,-*] image +.ih +BUGS + +It is currently not legal to transpose images with a wcs type of MULTISPEC. +.ih +SEE ALSO +.endhelp diff --git a/pkg/images/imgeom/doc/magnify.hlp b/pkg/images/imgeom/doc/magnify.hlp new file mode 100644 index 00000000..8b31817e --- /dev/null +++ b/pkg/images/imgeom/doc/magnify.hlp @@ -0,0 +1,202 @@ +.help magnify Dec98 images.imgeom +.ih +NAME +magnify -- interpolate two dimensional images +.ih +USAGE +.nf +magnify input output xmag ymag +.fi +.ih +PARAMETERS +.ls input +List of one or two dimensional images to be magnified. Image sections are +allowed. Images with an axis containing only one pixel are not magnified. +.le +.ls output +List of output image names. If the output image name is the same as the input +image name then the magnified image replaces the input image. +.le +.ls xmag, ymag +The magnification factors for the first and second image dimensions +respectively. The magnifications need not be integers. Magnifications +greater than 1 increase the size of the image while negative magnifications +less than -1 decrease the size by the specified factor. Magnifications +between -1 and 1 are interpreted as reciprocal magnifications. +.le +.ls x1 = INDEF, x2 = INDEF +The starting and ending coordinates in x in the input image which become +the first and last pixel in x in the magnified image. The values need not +be integers. If indefinite the values default to the first and last pixel +in x of the input image; i.e. a value of 1 and nx. +.le +.ls y1 = INDEF, y2 = INDEF +The starting and ending coordinates in y in the input image which become +the first and last pixel in y in the magnified image. The values need not +be integers. If indefinite the values default to the first and last pixel +in y of the input image; i.e. a value of 1 and ny. +.le +.ls dx = INDEF, dy = INDEF +The intervals between the output pixels in terms of the input image. +The values need not be integers. If these values are specified they +override the magnification factors. +.le +.ls interpolant = "linear" +The interpolant used for rebinning the image. +The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are < 1.0. +.le +.le +.ls boundary = "nearest" +Boundary extension type for references to pixels outside the bounds of the +input image. The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate value by reflecting about the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +Constant value for constant boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux. +.le +.ls logfile = STDOUT +Log file for recording information about the magnification. A null +logfile may be used to turn off log information. +.le +.ih +DESCRIPTION +The list of input images are expanded or contracted by interpolation +to form the output images. The output image names are specified by the +output list. The number of output image names must be the +same as the number of input images. An output image name may be the same +as the corresponding input image in which case the magnified image replaces +the input image. The input images must be one or two dimensional and each +axis must be of at least length 2 (i.e. there have to be distinct +endpoints between which to interpolate). + +The magnification factor determines the pixel step size or interval. +Positive magnifications are related to the step size as the reciprocal; +for example a magnification of 2.5 implies a step size of .4 and a +magnification of .2 implies a step size of 5. Negative magnifications +are related to the step size as the absolute value; for example a +magnification of -2.2 implies a step size of 2.2. This definition +frees the user from dealing with reciprocals and irrational numbers. +Note that the step size may be specified directly with the parameters +\fIdx\fR and \fIdy\fR, in which case the magnification factor is +not required. + +If fluxconserve = yes, the magnification is approximately flux conserving +in that the image values are scaled by the ratio of the output to the input +pixel areas; i.e dx * dy. + +In the default case with only the magnifications specified the full +image is expanded or contracted. By specifying additional parameters +the size and origin of the output image may be changed. Only those +parameters to be fixed need to be specified and the values of the +remaining parameters are either determined from these values or +default as indicated in the PARAMETERS section. + +The user may select the type of two dimensional interpolation and boundary +extension to be used. Note that the image interpolation is performed on +the boundary extended input image. Thus, boundary extensions which are +discontinuous (constant and wrap) may introduce interpolation errors. +.ih +EXAMPLES +1. To expand an image by a factor of 2.5: + + cl> magnify imagein imageout 2.5 2.5 + +2. To subsample the lines of an image in steps of 3.5: + + cl> magnify imagein imageout dx=3.5 dy=1 + +3. To magnify the central part of an image by 2 into a 11 by 31 image: + +.nf + cl> magnify imagein imageout 2 2 x1=25.3 x2=30.3 \ + >>> y1=20 y2=35 +.fi + +4. To use a higher order interpolator with wrap around boundary extension: + +.nf + cl> magnify imagein imageout 2 2 x1=-10 y1=-10 \ + >>> interpolation=spline3 boundary=wrap +.fi + +It is important to remember that the magnification affects the pixel intervals! +This means that the number of pixels in an expanded image is not simply +a multiple of the original number. The following example illustrates this +point. Begin with an image which is 100 by 10. This means the +x coordinates run between 1 and 100 and the y coordinates run between 1 and +10 with a pixel interval of 1. + +Let's magnify the x axis by 0.5 and the y axis by 2. +The output pixel intervals, in terms of the input pixel intervals, +are then 2 and 0.5. This means the output x pixels are at +1, 3, 5, etc. and output y pixels are at 1, 1.5, 2, 2.5, etc., again in +terms of the input pixel coordinates. The last output x pixel is then +at 99 in the input coordinates and the number of pixels is 50. For the +y axis the last output pixel is at 10 in the input coordinates and the +number of pixels between 1 and 10 in intervals of 0.5 is 19! Thus, the +final image is 50 by 19 and not 50 by 20 which you would get if you +multiplied the axis lengths by the magnification factors. + +A more complex example is given above in which x1=25.3, +x2=30.3, y1=20, and y2=35 with magnification factors of 2. +It is important to understand why the output image is 11 by 31 and +what the pixel coordinates are in terms of the input pixel coordinates. +.ih +SEE ALSO +imshift, blkavg, rotate, imlintran, register, geotran, geomap +.endhelp diff --git a/pkg/images/imgeom/doc/rotate.hlp b/pkg/images/imgeom/doc/rotate.hlp new file mode 100644 index 00000000..2b534738 --- /dev/null +++ b/pkg/images/imgeom/doc/rotate.hlp @@ -0,0 +1,164 @@ +.help rotate Dec98 images.imgeom +.ih +NAME +rotate -- rotate and shift a list of images +.ih +USAGE +rotate input output rotation +.ih +PARAMETERS +.ls input +List of images to be rotated. +.le +.ls output +List of output images. +.le +.ls rotation +Angle of rotation of the image in degrees. Positive angles will rotate +the image counter-clockwise from the x axis. +.le +.ls xin = INDEF, yin = INDEF +The origin of the rotation in pixels. Xin and yin default to the center of +the input image. +.le +.ls xout = INDEF, yout = INDEF +The origin of the output image. Xout and yout default to the center of the +output image. +.le +.ls ncols = INDEF, nlines = INDEF +The number of columns and rows in the output image. The default is to +keep the dimensions the same as the input image. If ncols and nrows is +less then or equal to zero the program will compute the number of columns +and rows needed to include the whole image, excluding the effects of +any origin shifts. +.le +.ls interpolant = "linear" +The interpolant. The options are the following: +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate a value by reflecting around the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The value of the constant for constant boundary extension. +.le +.ls nxblock = 512, nyblock = 512 +If the dimensions of the output image are less than nxblock and nyblock +then the entire image is rotated at once. Otherwise nxblock by nyblock +segments of the image are rotated. +.le +.ih +DESCRIPTION + +ROTATE rotates the list of images in input by rotation degrees and writes +the output to the images specified by output. The origins of the input and +output images may be specified by setting xin, yin, xout and yout. The +transformation is described below. + +.nf + xt = (x - xin) * cos (rotation) - (y - yin) * sin (rotation) + xout + yt = (x - xin) * sin (rotation) + (y - yin) * cos (rotation) + yout + +.fi + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels. ROTATE uses the +routines in the 2-D interpolation package. + +.ih +EXAMPLES + +.nf +1. Rotate an image 45 degrees around its center. + + cl> rotate m51 m51r45 45.0 + +2. Rotate an image by 45 degrees around (100., 100.) and + shift the origin to (150., 150.0) using bicubic interpolation. + + cl> rotate m92 m92r45 45.0 xin=100. yin=100. xout=150. yout=150.\ + >>> interp=poly3 + +3. Rotate an image 90 degrees counter-clockwise and clockwise around its + center. Note the use of imtranspose and image section notation. + + cl> imtranspose m92[*,-*] m92d90 + + cl> imtranspose m92[-*,*] m92d270 + +4. Rotate an image 180 degrees counter-clockwise. Note the use of imcopy + and image section notation. + + cl> imcopy m92[-*,-*] m92d180 +.fi + +.ih +TIMINGS +It requires approximately 70 and 290 cpu seconds to rotate a 512 by 512 +real image using bilinear and biquintic interpolation respectively +(Vax 11/750 fpa). +.ih +BUGS +The interpolation operation is done in real arithmetic. However the output +type of the pixels is set equal to the input type. This can lead to truncation +problems for integer images. + +Simple 90, 180, 270 etc degree rotations are best performed using the +imtranspose task and/or image section notation. +.ih +SEE ALSO +imtranspose, imshift, magnify, lintran, geotran, geomap +.endhelp diff --git a/pkg/images/imgeom/doc/shiftlines.hlp b/pkg/images/imgeom/doc/shiftlines.hlp new file mode 100644 index 00000000..856ab3a8 --- /dev/null +++ b/pkg/images/imgeom/doc/shiftlines.hlp @@ -0,0 +1,119 @@ +.help shiftlines Dec98 images.imgeom +.ih +NAME +shiftlines -- shift lines in a list of images +.ih +USAGE +.nf +shiftlines input output shift +.fi +.ih +PARAMETERS +.ls input +List of images to be shifted. Image sections are allowed. +.le +.ls output +List of output image names. If the output image name is the same as the input +image name then the shifted image replaces the input image. +.le +.ls shift +Shift in pixels. +.le +.ls interp_type = "linear" +The interpolant type use to computed the output shifted image. +The choices are the following: +.ls nearest +nearest neighbor interpolation. +.le +.ls linear +linear interpolation in x. +.le +.ls poly3 +third order interior polynomial in x. +.le +.ls poly5 +fifth order interior polynomial in x. +.le +.ls spline3 +cubic spline in x. +.le +.ls sinc +sinc interpolation in x. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 pixel wide sinc interpolant. The sinc width input by the user will +be rounded up to the nearest odd number. The default sinc width +is 31 pixels. +.le +.ls drizzle +1D drizzle resampling. Users can specify the drizzle pixel fraction +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. The +value 0.0 is increased to 0.001. Drizzle resampling with a pixel fraction +of 1.0 is identical to linear interpolation. +.le +.le +.ls boundary_type = "nearest" +Boundary condition for shifts outside the input image. +The minimum match abbreviated choices are: +.ls "nearest" +Use the values of the nearest boundary pixel. +.le +.ls "wrap" +Generate a value by wrapping around to the opposite boundary. +.le +.ls "reflect" +Generate a value by reflecting around the boundary +.le +.ls "constant" +Use a user supplied constant pixel value. +.le +.le +.ls constant = "0.0" +The constant for constant boundary extension. +.le +.ih +DESCRIPTION +The list of images in \fIinput\fR is shifted by the amount \fIshift\fR +and copied to the list of output images \fIoutput\fR. +The number of output image names must be the same as the number of input +images. An output image name may be the same as the corresponding +input image in which case the shifted image replaces the input image. + +The shift is defined by the following relation. + + xout = xint + shift + +Features in the input image are moved to higher columns when the shift +is positive and to lower columns when the shift is negative. For example, +to shift a feature at column 10 to column 12 the shift is 2.0. The task +has been optimized for integral pixel shifts. + +There are five choices for the one dimensional image interpolation +which is selected with the parameter \fIinterp_type\fR. +The value of the output pixels corresponding to input pixel positions +outside the boundaries of the image is determined by the parameter +\fIboundary_type\fR. + +.ih +EXAMPLES + +1. Shift the lines of an image by 0.25 pixels to the right. + + cl> shiftlines imagein imageout 0.25 + +2. Shift the lines of an image by -.3 pixels using cubic spline interpolation +and replace the input image by the output image. + + cl> shiftlines image image -.3 interp=spline3 + +.ih +TIMINGS +It requires approximately 28 and 59 seconds to shift a 512 square image +using linear and cubic spline interpolation respectively +(Vax 11/750 with fpa). +.ih +BUGS +.ih +SEE ALSO +imshift, magnify, rotate, imlintran, blkrep, blkav, geotran +.endhelp diff --git a/pkg/images/imgeom/im3dtran.par b/pkg/images/imgeom/im3dtran.par new file mode 100644 index 00000000..3c993815 --- /dev/null +++ b/pkg/images/imgeom/im3dtran.par @@ -0,0 +1,9 @@ +# Parameter list for the IM3DTRAN task + +input,s,a,,,,Input 3d image +output,s,a,,,,Output 3d image +new_x,i,a,3,1,3,"New x axis" +new_y,i,a,2,1,3,"New y axis" +new_z,i,a,1,1,3,"New z axis" +len_blk,i,h,128,,,Working block size in pixels +verbose,b,h,yes,,,Print messages about actions taken by the task ? diff --git a/pkg/images/imgeom/imgeom.cl b/pkg/images/imgeom/imgeom.cl new file mode 100644 index 00000000..8642c8f7 --- /dev/null +++ b/pkg/images/imgeom/imgeom.cl @@ -0,0 +1,30 @@ +#{ IMGEOM -- The Image Geometric Transformation Package. + +set imgeom = "images$imgeom/" + +package imgeom + +# Tasks. + +task blkavg, + blkrep, + imshift, + imtranspose, + im3dtran, + magnify, + shiftlines = "imgeom$x_images.e" + +# Tasks in other packages + +# Geotran is used by the imlintran and rotate tasks. + +task geotran = "immatch$x_images.e" +hidetask geotran + +# Scripts + +task imlintran = "imgeom$imlintran.cl" +task rotate = "imgeom$rotate.cl" + + +clbye() diff --git a/pkg/images/imgeom/imgeom.hd b/pkg/images/imgeom/imgeom.hd new file mode 100644 index 00000000..c9ed726a --- /dev/null +++ b/pkg/images/imgeom/imgeom.hd @@ -0,0 +1,16 @@ +# Help directory for the IMGEOM package + +$doc = "images$imgeom/doc/" +$src = "images$imgeom/src/" + +blkavg hlp=doc$blkavg.hlp, src=src$t_blkavg.x +blkrep hlp=doc$blkrep.hlp, src=src$t_blkrep.x +imlintran hlp=doc$imlintran.hlp, src=imgeom$imlintran.cl +imshift hlp=doc$imshift.hlp, src=src$t_imshift.x +imtranspose hlp=doc$imtrans.hlp, src=src$t_imtrans.x +im3dtran hlp=doc$im3dtran.hlp, src=src$t_im3dtran.x +magnify hlp=doc$magnify.hlp, src=src$t_magnify.x +rotate hlp=doc$rotate.hlp, src=imgeom$rotate.cl +shiftlines hlp=doc$shiftlines.hlp, src=src$t_shiftlines.x +revisions sys=Revisions + diff --git a/pkg/images/imgeom/imgeom.men b/pkg/images/imgeom/imgeom.men new file mode 100644 index 00000000..565f5b6d --- /dev/null +++ b/pkg/images/imgeom/imgeom.men @@ -0,0 +1,9 @@ + blkavg - Block average or sum a list of N-D images + blkrep - Block replicate a list of N-D images + imlintran - Linearly transform a list of 2-D images + imshift - Shift a list of 1-D or 2-D images + imtranspose - Transpose a list of 2-D images + im3dtran - Transpose a list of 3-D images + magnify - Magnify a list of 1-D or 2-D images + rotate - Rotate and shift a list of 2-D images + shiftlines - Shift the lines of a list of N-D images diff --git a/pkg/images/imgeom/imgeom.par b/pkg/images/imgeom/imgeom.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/imgeom/imgeom.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/imgeom/imlintran.cl b/pkg/images/imgeom/imlintran.cl new file mode 100644 index 00000000..59db414f --- /dev/null +++ b/pkg/images/imgeom/imlintran.cl @@ -0,0 +1,50 @@ +# IMLINTRAN -- Linearly transform and image by calling the GEOTRAN task +# with the appropriate parameters. + +procedure imlintran (input, output, xrotation, yrotation, xmag, ymag, xin, yin, + xout, yout, ncols, nlines, interpolant, boundary, constant, + fluxconserve, nxblock, nyblock, verbose) + +string input +string output +real xrotation +real yrotation +real xmag +real ymag +real xin +real yin +real xout +real yout +real ncols +real nlines +string interpolant +string boundary +real constant +bool fluxconserve +int nxblock +int nyblock +bool verbose + + +begin + # Declare local variables. + string tinput, toutput + real txrotation, tyrotation + + # Get the parameters. + tinput = input + toutput = output + txrotation = xrotation + tyrotation = yrotation + + # Call GEOTRAN. + geotran (input=tinput, output=toutput, database="", + xrotation=txrotation, yrotation=tyrotation, xin=xin, yin=yin, + xout=xout, yout=yout, xshift=INDEF, yshift=INDEF, xmin=1.0, + xmax=ncols, ymin=1.0, ymax=nlines, xscale=1.0, yscale=1.0, + ncols=INDEF, nlines=INDEF, xmag=xmag, ymag=ymag, + interpolant=interpolant, boundary=boundary, constant=constant, + xsample=1., ysample=1., fluxconserve=fluxconserve, nxblock=nxblock, + nyblock=nyblock, verbose=verbose) +end + diff --git a/pkg/images/imgeom/imlintran.par b/pkg/images/imgeom/imlintran.par new file mode 100644 index 00000000..a45ed454 --- /dev/null +++ b/pkg/images/imgeom/imlintran.par @@ -0,0 +1,30 @@ +# IMLINTRAN Parameters + +# Required parameters. +input,f,a,,,,Input data +output,f,a,,,,Output data +xrotation,r,a,,,,X rotation angle in degrees +yrotation,r,a,,,,Y rotation angle in degrees +xmag,r,a,1.0,0.0,,X output pixels per input pixel +ymag,r,a,1.0,0.0,,Y output pixels per input pixel + +# Change transformation parameters. +xin,r,h,INDEF,1.,,X origin of input image in pixels +yin,r,h,INDEF,1.,,Y origin of input image in pixels +xout,r,h,INDEF,1.,,X origin of output image in pixels +yout,r,h,INDEF,1.,,Y origin of output image in pixels +ncols,r,h,INDEF,,,Number of columns in the output image +nlines,r,h,INDEF,,,Number of lines in the output image + +# Coordinate surface and image interpolation parameters. +interpolant,s,h,'linear',,,'Interpolant (nearest,linear,poly3,poly5,spline3,sinc,lsinc,drizzle)' +boundary,s,h,'nearest',|nearest|constant|reflect|wrap|,,'Boundary extension (nearest,constant,reflect,wrap)' +constant,r,h,0.,,,Constant for constant boundary extension +fluxconserve,b,h,yes,,,Preserve image flux ? + +# Transformation blocking factors. +nxblock,i,h,512,,,X dimension of working block size in pixels +nyblock,i,h,512,,,Y dimension of working block size in pixels +verbose,b,h,yes,,,Print messages about the progress of the task ? + +mode,s,h,'ql' diff --git a/pkg/images/imgeom/imshift.par b/pkg/images/imgeom/imshift.par new file mode 100644 index 00000000..bcd630c1 --- /dev/null +++ b/pkg/images/imgeom/imshift.par @@ -0,0 +1,11 @@ +# IMSHIFT + +input,f,a,,,,Input images to be fit +output,f,a,,,,Output images +xshift,r,a,,,,Fractional pixel shift in x +yshift,r,a,,,,Fractional pixel shift in y +shifts_file,f,h,"",,,Text file containing shifts for each image +interp_type,s,h,'linear',,,'Interpolant (nearest,linear,poly3,poly5,spline3,sinc,drizzle)' +boundary_type,s,h,'nearest',"|nearest|constant|reflect|wrap|",,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0,,,Constant for boundary extension +mode,s,h,'ql' diff --git a/pkg/images/imgeom/imtranspose.par b/pkg/images/imgeom/imtranspose.par new file mode 100644 index 00000000..d77fe522 --- /dev/null +++ b/pkg/images/imgeom/imtranspose.par @@ -0,0 +1,3 @@ +input,s,a,,,,Images to be transposed +output,s,a,,,,Output image names +len_blk,i,h,512,,,Size in pixels of internal subraster diff --git a/pkg/images/imgeom/junk.cl b/pkg/images/imgeom/junk.cl new file mode 100644 index 00000000..59db414f --- /dev/null +++ b/pkg/images/imgeom/junk.cl @@ -0,0 +1,50 @@ +# IMLINTRAN -- Linearly transform and image by calling the GEOTRAN task +# with the appropriate parameters. + +procedure imlintran (input, output, xrotation, yrotation, xmag, ymag, xin, yin, + xout, yout, ncols, nlines, interpolant, boundary, constant, + fluxconserve, nxblock, nyblock, verbose) + +string input +string output +real xrotation +real yrotation +real xmag +real ymag +real xin +real yin +real xout +real yout +real ncols +real nlines +string interpolant +string boundary +real constant +bool fluxconserve +int nxblock +int nyblock +bool verbose + + +begin + # Declare local variables. + string tinput, toutput + real txrotation, tyrotation + + # Get the parameters. + tinput = input + toutput = output + txrotation = xrotation + tyrotation = yrotation + + # Call GEOTRAN. + geotran (input=tinput, output=toutput, database="", + xrotation=txrotation, yrotation=tyrotation, xin=xin, yin=yin, + xout=xout, yout=yout, xshift=INDEF, yshift=INDEF, xmin=1.0, + xmax=ncols, ymin=1.0, ymax=nlines, xscale=1.0, yscale=1.0, + ncols=INDEF, nlines=INDEF, xmag=xmag, ymag=ymag, + interpolant=interpolant, boundary=boundary, constant=constant, + xsample=1., ysample=1., fluxconserve=fluxconserve, nxblock=nxblock, + nyblock=nyblock, verbose=verbose) +end + diff --git a/pkg/images/imgeom/magnify.par b/pkg/images/imgeom/magnify.par new file mode 100644 index 00000000..8f1fbf5f --- /dev/null +++ b/pkg/images/imgeom/magnify.par @@ -0,0 +1,17 @@ +# Magnify parameters + +input,s,a,,,,Input two dimensional images +output,s,a,,,,Output magnified images +xmag,r,a,,,,X magnification factor +ymag,r,a,,,,Y magnification factor +x1,r,h,INDEF,,,X window origin relative to input image +x2,r,h,INDEF,,,X window end point relative to input image +dx,r,h,INDEF,0.,,X Pixel interval relative to input image +y1,r,h,INDEF,,,Y window origin relative to input image +y2,r,h,INDEF,,,Y window end point relative to input image +dy,r,h,INDEF,0.,,Y Pixel interval relative to input image +interpolation,s,h,linear,,,"Interpolation type(nearest,linear,poly3,poly5,spline3,sinc,lsinc,drizzle" +boundary,s,h,nearest,"|nearest|constant|reflect|wrap|",,"Boundary extension type (constant,nearest,reflect,wrap)" +constant,r,h,0.,,,Boundary extension constant +fluxconserve,b,h,yes,,,Preserve total image flux? +logfile,f,h,STDOUT,,,Log file diff --git a/pkg/images/imgeom/mkpkg b/pkg/images/imgeom/mkpkg new file mode 100644 index 00000000..b196aebc --- /dev/null +++ b/pkg/images/imgeom/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMGEOTRAN Package + +libpkg.a: + @src + ; diff --git a/pkg/images/imgeom/rotate.cl b/pkg/images/imgeom/rotate.cl new file mode 100644 index 00000000..249fb50e --- /dev/null +++ b/pkg/images/imgeom/rotate.cl @@ -0,0 +1,43 @@ +# ROTATE -- Rotate an image by calling the GEOTRAN task with the appropriate +# parameters. + +procedure rotate (input, output, rotation, xin, yin, xout, yout, ncols, nlines, + interpolant, boundary, constant, nxblock, nyblock, verbose) + +string input +string output +real rotation +real xin +real yin +real xout +real yout +real ncols +real nlines +string interpolant +string boundary +real constant +int nxblock +int nyblock +bool verbose + + +begin + # Declare local variables. + string tinput, toutput + real trotation + + # Get the parameters. + tinput = input + toutput = output + trotation = rotation + + # Call GEOTRAN. + geotran (input=tinput, output=toutput, database="", xrotation=trotation, + yrotation=trotation, xin=xin, yin=yin, xout=xout, yout=yout, + xshift=INDEF, yshift=INDEF, xmin=1.0, xmax=ncols, ymin=1.0, + ymax=nlines, xscale=1.0, yscale=1.0, ncols=INDEF, nlines=INDEF, + xmag=INDEF, ymag=INDEF, interpolant=interpolant, + boundary=boundary, constant=constant, xsample=1., ysample=1., + fluxconserve=no, nxblock=nxblock, nyblock= nyblock, verbose=verbose) +end + diff --git a/pkg/images/imgeom/rotate.par b/pkg/images/imgeom/rotate.par new file mode 100644 index 00000000..9e44b99b --- /dev/null +++ b/pkg/images/imgeom/rotate.par @@ -0,0 +1,24 @@ +# ROTATE Parameters + +# Required parameters. +input,f,a,,,,Input data +output,f,a,,,,Output data +rotation,r,a,,,,Rotation angle in degrees + +# Transformation parameters. +xin,r,h,INDEF,,,X origin of input image in pixels +yin,r,h,INDEF,,,Y origin of input image in pixels +xout,r,h,INDEF,,,X origin of output image in pixels +yout,r,h,INDEF,,,Y origin of output image in pixels +ncols,r,h,INDEF,,,Number of columns in the output image +nlines,r,h,INDEF,,,Number of lines in the output image + +# Image interpolation parameters. +interpolant,s,h,'linear',,,'Interpolant (nearest,linear,poly3,poly5,spline3,sinc,lsinc,drizzle)' +boundary,s,h,'nearest',|nearest|constant|reflect|wrap|,,'Boundary extension (nearest,constant,reflect,wrap)' +constant,r,h,0.,,,Constant for constant boundary extension +nxblock,i,h,512,,,X dimension of working block size in pixels +nyblock,i,h,512,,,Y dimension of working block size in pixels +verbose,b,h,yes,,,Print messages about the progress of the task ? + +mode,s,h,'ql' diff --git a/pkg/images/imgeom/shiftlines.par b/pkg/images/imgeom/shiftlines.par new file mode 100644 index 00000000..957f8b98 --- /dev/null +++ b/pkg/images/imgeom/shiftlines.par @@ -0,0 +1,9 @@ +# Task parameters for SHIFTLINES. + +input,s,a,,,,Input images +output,s,a,,,,Output images +shift,r,a,,,,Line shift in pixels +interp_type,s,h,"linear",,,'Interpolant (nearest,linear,poly3,poly5,spline3,sinc,drizzle)' +boundary_type,s,h,"nearest","|nearest|constant|reflect|wrap|",,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0.0,,,Constant for boundary extension +mode,s,h,ql diff --git a/pkg/images/imgeom/src/blkav.gx b/pkg/images/imgeom/src/blkav.gx new file mode 100644 index 00000000..9c83ebab --- /dev/null +++ b/pkg/images/imgeom/src/blkav.gx @@ -0,0 +1,131 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define AVG 1 # operation = arithmetic average +define SUM 2 # operation = arithmetic sum + +# change to (lrdx) in future +$for (lrd) + +# BLKAVG -- Block average or sum on n-dimensional images. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. Remainder pixels at the end +# of a line, col, etc. are averaged correctly. + +procedure blkav$t (im1, im2, blkfac, option) + +pointer im1 # input image +pointer im2 # output image +int blkfac[IM_MAXDIM] # blocking factors +int option # block operation (average, sum, ...) + +int num_oblks[IM_MAXDIM], i, count, ndim, dim, nlines_in_sum, nfull_blkx +int junk, num_ilines, num_olines, oline +long blkin_s[IM_MAXDIM], blkin_e[IM_MAXDIM] +long vin_s[IM_MAXDIM], vin_e[IM_MAXDIM], vout[IM_MAXDIM] +$if (datatype != l) +PIXEL sum +$else +real sum +$endif +pointer sp, accum_ptr, iline_ptr, oline_ptr + +int blkcomp(), imggs$t(), impnl$t() +errchk imggs$t(), impnl$t() + +begin + call smark (sp) + call salloc (accum_ptr, IM_LEN(im1, 1), TY_PIXEL) + + # Initialize; input and output vectors, block counters. + ndim = IM_NDIM(im1) + nfull_blkx = IM_LEN(im1, 1) / blkfac[1] + blkin_s[1] = long(1) + blkin_e[1] = long(IM_LEN(im1, 1)) + vin_s[1] = blkin_s[1] + vin_e[1] = blkin_e[1] + + do i = 1, ndim { + num_oblks[i] = (IM_LEN(im1,i) + blkfac[i] - 1) / blkfac[i] + IM_LEN(im2, i) = num_oblks[i] + } + num_olines = 1 + do i = 2, ndim + num_olines = num_olines * num_oblks[i] + call amovkl (long(1), vout, IM_MAXDIM) + + # For each sequential output-image line, ... + do oline = 1, num_olines { + + call aclr$t (Mem$t[accum_ptr], IM_LEN(im1, 1)) + nlines_in_sum = 0 + + # Compute block vector; initialize dim>1 input vector. + num_ilines = blkcomp (im1, blkfac, vout, blkin_s, blkin_e, + vin_s, vin_e) + + # Output pointer; note impnl$t returns vout for NEXT output line. + junk = impnl$t (im2, oline_ptr, vout) + + # For all input lines mapping to current output line, ... + do i = 1, num_ilines { + # Get line from input image. + iline_ptr = imggs$t (im1, vin_s, vin_e, ndim) + + # Increment general section input vector between block bounds. + do dim = 2, ndim { + if (vin_s[dim] < blkin_e[dim]) { + vin_s[dim] = vin_s[dim] + 1 + vin_e[dim] = vin_s[dim] + break + } else { + vin_s[dim] = blkin_s[dim] + vin_e[dim] = vin_s[dim] + } + } + + # Accumulate line into block sum. Keep track of no. of + # lines in sum so that we can compute block average later. + + call aadd$t (Mem$t[iline_ptr], Mem$t[accum_ptr], + Mem$t[accum_ptr], IM_LEN(im1,1)) + nlines_in_sum = nlines_in_sum + 1 + } + + # We now have a templine of sums; average/sum into output buffer + # first the full blocks using a vop. + if (option == AVG) + call abav$t (Mem$t[accum_ptr], Mem$t[oline_ptr], nfull_blkx, + blkfac[1]) + else + call absu$t (Mem$t[accum_ptr], Mem$t[oline_ptr], nfull_blkx, + blkfac[1]) + + # Now average/sum the final partial block in x, if any. + if (nfull_blkx < num_oblks[1]) { + sum = 0$f + count = 0 + do i = nfull_blkx * blkfac[1] + 1, IM_LEN(im1,1) { + sum = sum + Mem$t[accum_ptr+i-1] + count = count + 1 + } + if (option == AVG) + Mem$t[oline_ptr+num_oblks[1]-1] = sum / count + else + Mem$t[oline_ptr+num_oblks[1]-1] = sum + } + + # Block average into output line from the sum of all lines block + # averaged in X. + if (option == AVG) + call adivk$t (Mem$t[oline_ptr], PIXEL(nlines_in_sum), + Mem$t[oline_ptr], num_oblks[1]) + } + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/imgeom/src/blkcomp.x b/pkg/images/imgeom/src/blkcomp.x new file mode 100644 index 00000000..814be4ee --- /dev/null +++ b/pkg/images/imgeom/src/blkcomp.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# BLKCOMP -- compute starting and ending input vectors for blocks in each +# dimension. Initialize input-line vectors to block vectors. Return total +# number of input lines mapping to current output line. + +int procedure blkcomp (im1, blkfac, vout, blkin_s, blkin_e, + vin_s, vin_e) + +pointer im1 # pointer to input image descriptor +int blkfac[IM_MAXDIM] # blocking factors for each dimension +long vout[IM_MAXDIM] # output image vectors for each dimension +long blkin_s[IM_MAXDIM] # index of starting block for each dimension +long blkin_e[IM_MAXDIM] # index of ending block for each dimension +long vin_s[IM_MAXDIM] # initial starting input vector +long vin_e[IM_MAXDIM] # initial ending input vector + +int num_ilines, dim + +begin + num_ilines = 1 + + # Compute starting and ending indices of input image pixels in each + # dimension mapping to current output line. + + do dim = 2, IM_NDIM(im1) { + blkin_s[dim] = long(1 + (vout[dim] - 1) * blkfac[dim]) + blkin_e[dim] = long(min (IM_LEN(im1,dim), vout[dim] * blkfac[dim])) + vin_s[dim] = blkin_s[dim] + vin_e[dim] = blkin_s[dim] + num_ilines = num_ilines * (blkin_e[dim] - blkin_s[dim] + 1) + } + + return (num_ilines) +end + diff --git a/pkg/images/imgeom/src/blkrp.gx b/pkg/images/imgeom/src/blkrp.gx new file mode 100644 index 00000000..fb297633 --- /dev/null +++ b/pkg/images/imgeom/src/blkrp.gx @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$for (dlrs) + +# BLKRP -- Block replicate an image. + +procedure blkrp$t (in, out, blkfac) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +int blkfac[ARB] # Block replication factors + +int i, j, ndim, nin, nout +pointer sp, buf, buf1, buf2, buf3, v1, v2, v3, ptrin, ptrout +pointer imgl1$t(), impl1$t(), imgnl$t(), impnl$t() + +begin + call smark (sp) + + ndim = IM_NDIM(in) + nin = IM_LEN(in, 1) + nout = nin * blkfac[1] + IM_LEN(out,1) = nout + + if (ndim == 1) { + # For one dimensional images do the replication directly. + + buf1 = imgl1$t (in) + buf2 = impl1$t (out) + ptrin = buf1 + ptrout = buf2 + do i = 1, nin { + do j = 1, blkfac[1] { + Mem$t[ptrout] = Mem$t[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + + } else { + # For higher dimensional images use line access routines. + + do i = 2, ndim + IM_LEN(out,i) = IM_LEN(in,i) * blkfac[i] + + # Allocate memory. + call salloc (buf, nout, TY_PIXEL) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + + # Initialize the input line vector and the output section vectors. + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + # For each output line compute a block replicated line from the + # input image. If the line replication factor is greater than + # 1 then simply repeat the input line. This algorithm is + # sequential in both the input and output image though the + # input image will be recycled for each repetition of higher + # dimensions. + + while (impnl$t (out, buf2, Meml[v2]) != EOF) { + # Get the input vector corresponding to the output line. + do i = 2, ndim + Meml[v1+i-1] = (Meml[v3+i-1] - 1) / blkfac[i] + 1 + i = imgnl$t (in, buf1, Meml[v1]) + + # Block replicate the columns. + if (blkfac[1] == 1) + buf3 = buf1 + else { + ptrin = buf1 + ptrout = buf + do i = 1, nin { + do j = 1, blkfac[1] { + Mem$t[ptrout] = Mem$t[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + buf3 = buf + } + + # Copy the input line to the output line. + call amov$t (Mem$t[buf3], Mem$t[buf2], nout) + + # Repeat for each repetition of the input line. + for (i=2; i <= blkfac[2]; i=i+1) { + j = impnl$t (out, buf2, Meml[v2]) + call amov$t (Mem$t[buf3], Mem$t[buf2], nout) + } + + call amovl (Meml[v2], Meml[v3], IM_MAXDIM) + } + } + + call sfree (sp) +end +$endfor diff --git a/pkg/images/imgeom/src/generic/blkav.x b/pkg/images/imgeom/src/generic/blkav.x new file mode 100644 index 00000000..5a7df840 --- /dev/null +++ b/pkg/images/imgeom/src/generic/blkav.x @@ -0,0 +1,361 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define AVG 1 # operation = arithmetic average +define SUM 2 # operation = arithmetic sum + +# change to (lrdx) in future + + +# BLKAVG -- Block average or sum on n-dimensional images. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. Remainder pixels at the end +# of a line, col, etc. are averaged correctly. + +procedure blkavl (im1, im2, blkfac, option) + +pointer im1 # input image +pointer im2 # output image +int blkfac[IM_MAXDIM] # blocking factors +int option # block operation (average, sum, ...) + +int num_oblks[IM_MAXDIM], i, count, ndim, dim, nlines_in_sum, nfull_blkx +int junk, num_ilines, num_olines, oline +long blkin_s[IM_MAXDIM], blkin_e[IM_MAXDIM] +long vin_s[IM_MAXDIM], vin_e[IM_MAXDIM], vout[IM_MAXDIM] +real sum +pointer sp, accum_ptr, iline_ptr, oline_ptr + +int blkcomp(), imggsl(), impnll() +errchk imggsl(), impnll() + +begin + call smark (sp) + call salloc (accum_ptr, IM_LEN(im1, 1), TY_LONG) + + # Initialize; input and output vectors, block counters. + ndim = IM_NDIM(im1) + nfull_blkx = IM_LEN(im1, 1) / blkfac[1] + blkin_s[1] = long(1) + blkin_e[1] = long(IM_LEN(im1, 1)) + vin_s[1] = blkin_s[1] + vin_e[1] = blkin_e[1] + + do i = 1, ndim { + num_oblks[i] = (IM_LEN(im1,i) + blkfac[i] - 1) / blkfac[i] + IM_LEN(im2, i) = num_oblks[i] + } + num_olines = 1 + do i = 2, ndim + num_olines = num_olines * num_oblks[i] + call amovkl (long(1), vout, IM_MAXDIM) + + # For each sequential output-image line, ... + do oline = 1, num_olines { + + call aclrl (Meml[accum_ptr], IM_LEN(im1, 1)) + nlines_in_sum = 0 + + # Compute block vector; initialize dim>1 input vector. + num_ilines = blkcomp (im1, blkfac, vout, blkin_s, blkin_e, + vin_s, vin_e) + + # Output pointer; note impnl$t returns vout for NEXT output line. + junk = impnll (im2, oline_ptr, vout) + + # For all input lines mapping to current output line, ... + do i = 1, num_ilines { + # Get line from input image. + iline_ptr = imggsl (im1, vin_s, vin_e, ndim) + + # Increment general section input vector between block bounds. + do dim = 2, ndim { + if (vin_s[dim] < blkin_e[dim]) { + vin_s[dim] = vin_s[dim] + 1 + vin_e[dim] = vin_s[dim] + break + } else { + vin_s[dim] = blkin_s[dim] + vin_e[dim] = vin_s[dim] + } + } + + # Accumulate line into block sum. Keep track of no. of + # lines in sum so that we can compute block average later. + + call aaddl (Meml[iline_ptr], Meml[accum_ptr], + Meml[accum_ptr], IM_LEN(im1,1)) + nlines_in_sum = nlines_in_sum + 1 + } + + # We now have a templine of sums; average/sum into output buffer + # first the full blocks using a vop. + if (option == AVG) + call abavl (Meml[accum_ptr], Meml[oline_ptr], nfull_blkx, + blkfac[1]) + else + call absul (Meml[accum_ptr], Meml[oline_ptr], nfull_blkx, + blkfac[1]) + + # Now average/sum the final partial block in x, if any. + if (nfull_blkx < num_oblks[1]) { + sum = 0 + count = 0 + do i = nfull_blkx * blkfac[1] + 1, IM_LEN(im1,1) { + sum = sum + Meml[accum_ptr+i-1] + count = count + 1 + } + if (option == AVG) + Meml[oline_ptr+num_oblks[1]-1] = sum / count + else + Meml[oline_ptr+num_oblks[1]-1] = sum + } + + # Block average into output line from the sum of all lines block + # averaged in X. + if (option == AVG) + call adivkl (Meml[oline_ptr], long(nlines_in_sum), + Meml[oline_ptr], num_oblks[1]) + } + + call sfree (sp) +end + + + +# BLKAVG -- Block average or sum on n-dimensional images. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. Remainder pixels at the end +# of a line, col, etc. are averaged correctly. + +procedure blkavr (im1, im2, blkfac, option) + +pointer im1 # input image +pointer im2 # output image +int blkfac[IM_MAXDIM] # blocking factors +int option # block operation (average, sum, ...) + +int num_oblks[IM_MAXDIM], i, count, ndim, dim, nlines_in_sum, nfull_blkx +int junk, num_ilines, num_olines, oline +long blkin_s[IM_MAXDIM], blkin_e[IM_MAXDIM] +long vin_s[IM_MAXDIM], vin_e[IM_MAXDIM], vout[IM_MAXDIM] +real sum +pointer sp, accum_ptr, iline_ptr, oline_ptr + +int blkcomp(), imggsr(), impnlr() +errchk imggsr(), impnlr() + +begin + call smark (sp) + call salloc (accum_ptr, IM_LEN(im1, 1), TY_REAL) + + # Initialize; input and output vectors, block counters. + ndim = IM_NDIM(im1) + nfull_blkx = IM_LEN(im1, 1) / blkfac[1] + blkin_s[1] = long(1) + blkin_e[1] = long(IM_LEN(im1, 1)) + vin_s[1] = blkin_s[1] + vin_e[1] = blkin_e[1] + + do i = 1, ndim { + num_oblks[i] = (IM_LEN(im1,i) + blkfac[i] - 1) / blkfac[i] + IM_LEN(im2, i) = num_oblks[i] + } + num_olines = 1 + do i = 2, ndim + num_olines = num_olines * num_oblks[i] + call amovkl (long(1), vout, IM_MAXDIM) + + # For each sequential output-image line, ... + do oline = 1, num_olines { + + call aclrr (Memr[accum_ptr], IM_LEN(im1, 1)) + nlines_in_sum = 0 + + # Compute block vector; initialize dim>1 input vector. + num_ilines = blkcomp (im1, blkfac, vout, blkin_s, blkin_e, + vin_s, vin_e) + + # Output pointer; note impnl$t returns vout for NEXT output line. + junk = impnlr (im2, oline_ptr, vout) + + # For all input lines mapping to current output line, ... + do i = 1, num_ilines { + # Get line from input image. + iline_ptr = imggsr (im1, vin_s, vin_e, ndim) + + # Increment general section input vector between block bounds. + do dim = 2, ndim { + if (vin_s[dim] < blkin_e[dim]) { + vin_s[dim] = vin_s[dim] + 1 + vin_e[dim] = vin_s[dim] + break + } else { + vin_s[dim] = blkin_s[dim] + vin_e[dim] = vin_s[dim] + } + } + + # Accumulate line into block sum. Keep track of no. of + # lines in sum so that we can compute block average later. + + call aaddr (Memr[iline_ptr], Memr[accum_ptr], + Memr[accum_ptr], IM_LEN(im1,1)) + nlines_in_sum = nlines_in_sum + 1 + } + + # We now have a templine of sums; average/sum into output buffer + # first the full blocks using a vop. + if (option == AVG) + call abavr (Memr[accum_ptr], Memr[oline_ptr], nfull_blkx, + blkfac[1]) + else + call absur (Memr[accum_ptr], Memr[oline_ptr], nfull_blkx, + blkfac[1]) + + # Now average/sum the final partial block in x, if any. + if (nfull_blkx < num_oblks[1]) { + sum = 0.0 + count = 0 + do i = nfull_blkx * blkfac[1] + 1, IM_LEN(im1,1) { + sum = sum + Memr[accum_ptr+i-1] + count = count + 1 + } + if (option == AVG) + Memr[oline_ptr+num_oblks[1]-1] = sum / count + else + Memr[oline_ptr+num_oblks[1]-1] = sum + } + + # Block average into output line from the sum of all lines block + # averaged in X. + if (option == AVG) + call adivkr (Memr[oline_ptr], real(nlines_in_sum), + Memr[oline_ptr], num_oblks[1]) + } + + call sfree (sp) +end + + + +# BLKAVG -- Block average or sum on n-dimensional images. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. Remainder pixels at the end +# of a line, col, etc. are averaged correctly. + +procedure blkavd (im1, im2, blkfac, option) + +pointer im1 # input image +pointer im2 # output image +int blkfac[IM_MAXDIM] # blocking factors +int option # block operation (average, sum, ...) + +int num_oblks[IM_MAXDIM], i, count, ndim, dim, nlines_in_sum, nfull_blkx +int junk, num_ilines, num_olines, oline +long blkin_s[IM_MAXDIM], blkin_e[IM_MAXDIM] +long vin_s[IM_MAXDIM], vin_e[IM_MAXDIM], vout[IM_MAXDIM] +double sum +pointer sp, accum_ptr, iline_ptr, oline_ptr + +int blkcomp(), imggsd(), impnld() +errchk imggsd(), impnld() + +begin + call smark (sp) + call salloc (accum_ptr, IM_LEN(im1, 1), TY_DOUBLE) + + # Initialize; input and output vectors, block counters. + ndim = IM_NDIM(im1) + nfull_blkx = IM_LEN(im1, 1) / blkfac[1] + blkin_s[1] = long(1) + blkin_e[1] = long(IM_LEN(im1, 1)) + vin_s[1] = blkin_s[1] + vin_e[1] = blkin_e[1] + + do i = 1, ndim { + num_oblks[i] = (IM_LEN(im1,i) + blkfac[i] - 1) / blkfac[i] + IM_LEN(im2, i) = num_oblks[i] + } + num_olines = 1 + do i = 2, ndim + num_olines = num_olines * num_oblks[i] + call amovkl (long(1), vout, IM_MAXDIM) + + # For each sequential output-image line, ... + do oline = 1, num_olines { + + call aclrd (Memd[accum_ptr], IM_LEN(im1, 1)) + nlines_in_sum = 0 + + # Compute block vector; initialize dim>1 input vector. + num_ilines = blkcomp (im1, blkfac, vout, blkin_s, blkin_e, + vin_s, vin_e) + + # Output pointer; note impnl$t returns vout for NEXT output line. + junk = impnld (im2, oline_ptr, vout) + + # For all input lines mapping to current output line, ... + do i = 1, num_ilines { + # Get line from input image. + iline_ptr = imggsd (im1, vin_s, vin_e, ndim) + + # Increment general section input vector between block bounds. + do dim = 2, ndim { + if (vin_s[dim] < blkin_e[dim]) { + vin_s[dim] = vin_s[dim] + 1 + vin_e[dim] = vin_s[dim] + break + } else { + vin_s[dim] = blkin_s[dim] + vin_e[dim] = vin_s[dim] + } + } + + # Accumulate line into block sum. Keep track of no. of + # lines in sum so that we can compute block average later. + + call aaddd (Memd[iline_ptr], Memd[accum_ptr], + Memd[accum_ptr], IM_LEN(im1,1)) + nlines_in_sum = nlines_in_sum + 1 + } + + # We now have a templine of sums; average/sum into output buffer + # first the full blocks using a vop. + if (option == AVG) + call abavd (Memd[accum_ptr], Memd[oline_ptr], nfull_blkx, + blkfac[1]) + else + call absud (Memd[accum_ptr], Memd[oline_ptr], nfull_blkx, + blkfac[1]) + + # Now average/sum the final partial block in x, if any. + if (nfull_blkx < num_oblks[1]) { + sum = 0.0D0 + count = 0 + do i = nfull_blkx * blkfac[1] + 1, IM_LEN(im1,1) { + sum = sum + Memd[accum_ptr+i-1] + count = count + 1 + } + if (option == AVG) + Memd[oline_ptr+num_oblks[1]-1] = sum / count + else + Memd[oline_ptr+num_oblks[1]-1] = sum + } + + # Block average into output line from the sum of all lines block + # averaged in X. + if (option == AVG) + call adivkd (Memd[oline_ptr], double(nlines_in_sum), + Memd[oline_ptr], num_oblks[1]) + } + + call sfree (sp) +end + + diff --git a/pkg/images/imgeom/src/generic/blkrp.x b/pkg/images/imgeom/src/generic/blkrp.x new file mode 100644 index 00000000..bc43a3e5 --- /dev/null +++ b/pkg/images/imgeom/src/generic/blkrp.x @@ -0,0 +1,397 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + + +# BLKRP -- Block replicate an image. + +procedure blkrpd (in, out, blkfac) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +int blkfac[ARB] # Block replication factors + +int i, j, ndim, nin, nout +pointer sp, buf, buf1, buf2, buf3, v1, v2, v3, ptrin, ptrout +pointer imgl1d(), impl1d(), imgnld(), impnld() + +begin + call smark (sp) + + ndim = IM_NDIM(in) + nin = IM_LEN(in, 1) + nout = nin * blkfac[1] + IM_LEN(out,1) = nout + + if (ndim == 1) { + # For one dimensional images do the replication directly. + + buf1 = imgl1d (in) + buf2 = impl1d (out) + ptrin = buf1 + ptrout = buf2 + do i = 1, nin { + do j = 1, blkfac[1] { + Memd[ptrout] = Memd[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + + } else { + # For higher dimensional images use line access routines. + + do i = 2, ndim + IM_LEN(out,i) = IM_LEN(in,i) * blkfac[i] + + # Allocate memory. + call salloc (buf, nout, TY_DOUBLE) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + + # Initialize the input line vector and the output section vectors. + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + # For each output line compute a block replicated line from the + # input image. If the line replication factor is greater than + # 1 then simply repeat the input line. This algorithm is + # sequential in both the input and output image though the + # input image will be recycled for each repetition of higher + # dimensions. + + while (impnld (out, buf2, Meml[v2]) != EOF) { + # Get the input vector corresponding to the output line. + do i = 2, ndim + Meml[v1+i-1] = (Meml[v3+i-1] - 1) / blkfac[i] + 1 + i = imgnld (in, buf1, Meml[v1]) + + # Block replicate the columns. + if (blkfac[1] == 1) + buf3 = buf1 + else { + ptrin = buf1 + ptrout = buf + do i = 1, nin { + do j = 1, blkfac[1] { + Memd[ptrout] = Memd[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + buf3 = buf + } + + # Copy the input line to the output line. + call amovd (Memd[buf3], Memd[buf2], nout) + + # Repeat for each repetition of the input line. + for (i=2; i <= blkfac[2]; i=i+1) { + j = impnld (out, buf2, Meml[v2]) + call amovd (Memd[buf3], Memd[buf2], nout) + } + + call amovl (Meml[v2], Meml[v3], IM_MAXDIM) + } + } + + call sfree (sp) +end + + +# BLKRP -- Block replicate an image. + +procedure blkrpl (in, out, blkfac) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +int blkfac[ARB] # Block replication factors + +int i, j, ndim, nin, nout +pointer sp, buf, buf1, buf2, buf3, v1, v2, v3, ptrin, ptrout +pointer imgl1l(), impl1l(), imgnll(), impnll() + +begin + call smark (sp) + + ndim = IM_NDIM(in) + nin = IM_LEN(in, 1) + nout = nin * blkfac[1] + IM_LEN(out,1) = nout + + if (ndim == 1) { + # For one dimensional images do the replication directly. + + buf1 = imgl1l (in) + buf2 = impl1l (out) + ptrin = buf1 + ptrout = buf2 + do i = 1, nin { + do j = 1, blkfac[1] { + Meml[ptrout] = Meml[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + + } else { + # For higher dimensional images use line access routines. + + do i = 2, ndim + IM_LEN(out,i) = IM_LEN(in,i) * blkfac[i] + + # Allocate memory. + call salloc (buf, nout, TY_LONG) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + + # Initialize the input line vector and the output section vectors. + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + # For each output line compute a block replicated line from the + # input image. If the line replication factor is greater than + # 1 then simply repeat the input line. This algorithm is + # sequential in both the input and output image though the + # input image will be recycled for each repetition of higher + # dimensions. + + while (impnll (out, buf2, Meml[v2]) != EOF) { + # Get the input vector corresponding to the output line. + do i = 2, ndim + Meml[v1+i-1] = (Meml[v3+i-1] - 1) / blkfac[i] + 1 + i = imgnll (in, buf1, Meml[v1]) + + # Block replicate the columns. + if (blkfac[1] == 1) + buf3 = buf1 + else { + ptrin = buf1 + ptrout = buf + do i = 1, nin { + do j = 1, blkfac[1] { + Meml[ptrout] = Meml[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + buf3 = buf + } + + # Copy the input line to the output line. + call amovl (Meml[buf3], Meml[buf2], nout) + + # Repeat for each repetition of the input line. + for (i=2; i <= blkfac[2]; i=i+1) { + j = impnll (out, buf2, Meml[v2]) + call amovl (Meml[buf3], Meml[buf2], nout) + } + + call amovl (Meml[v2], Meml[v3], IM_MAXDIM) + } + } + + call sfree (sp) +end + + +# BLKRP -- Block replicate an image. + +procedure blkrpr (in, out, blkfac) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +int blkfac[ARB] # Block replication factors + +int i, j, ndim, nin, nout +pointer sp, buf, buf1, buf2, buf3, v1, v2, v3, ptrin, ptrout +pointer imgl1r(), impl1r(), imgnlr(), impnlr() + +begin + call smark (sp) + + ndim = IM_NDIM(in) + nin = IM_LEN(in, 1) + nout = nin * blkfac[1] + IM_LEN(out,1) = nout + + if (ndim == 1) { + # For one dimensional images do the replication directly. + + buf1 = imgl1r (in) + buf2 = impl1r (out) + ptrin = buf1 + ptrout = buf2 + do i = 1, nin { + do j = 1, blkfac[1] { + Memr[ptrout] = Memr[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + + } else { + # For higher dimensional images use line access routines. + + do i = 2, ndim + IM_LEN(out,i) = IM_LEN(in,i) * blkfac[i] + + # Allocate memory. + call salloc (buf, nout, TY_REAL) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + + # Initialize the input line vector and the output section vectors. + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + # For each output line compute a block replicated line from the + # input image. If the line replication factor is greater than + # 1 then simply repeat the input line. This algorithm is + # sequential in both the input and output image though the + # input image will be recycled for each repetition of higher + # dimensions. + + while (impnlr (out, buf2, Meml[v2]) != EOF) { + # Get the input vector corresponding to the output line. + do i = 2, ndim + Meml[v1+i-1] = (Meml[v3+i-1] - 1) / blkfac[i] + 1 + i = imgnlr (in, buf1, Meml[v1]) + + # Block replicate the columns. + if (blkfac[1] == 1) + buf3 = buf1 + else { + ptrin = buf1 + ptrout = buf + do i = 1, nin { + do j = 1, blkfac[1] { + Memr[ptrout] = Memr[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + buf3 = buf + } + + # Copy the input line to the output line. + call amovr (Memr[buf3], Memr[buf2], nout) + + # Repeat for each repetition of the input line. + for (i=2; i <= blkfac[2]; i=i+1) { + j = impnlr (out, buf2, Meml[v2]) + call amovr (Memr[buf3], Memr[buf2], nout) + } + + call amovl (Meml[v2], Meml[v3], IM_MAXDIM) + } + } + + call sfree (sp) +end + + +# BLKRP -- Block replicate an image. + +procedure blkrps (in, out, blkfac) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +int blkfac[ARB] # Block replication factors + +int i, j, ndim, nin, nout +pointer sp, buf, buf1, buf2, buf3, v1, v2, v3, ptrin, ptrout +pointer imgl1s(), impl1s(), imgnls(), impnls() + +begin + call smark (sp) + + ndim = IM_NDIM(in) + nin = IM_LEN(in, 1) + nout = nin * blkfac[1] + IM_LEN(out,1) = nout + + if (ndim == 1) { + # For one dimensional images do the replication directly. + + buf1 = imgl1s (in) + buf2 = impl1s (out) + ptrin = buf1 + ptrout = buf2 + do i = 1, nin { + do j = 1, blkfac[1] { + Mems[ptrout] = Mems[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + + } else { + # For higher dimensional images use line access routines. + + do i = 2, ndim + IM_LEN(out,i) = IM_LEN(in,i) * blkfac[i] + + # Allocate memory. + call salloc (buf, nout, TY_SHORT) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + + # Initialize the input line vector and the output section vectors. + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + # For each output line compute a block replicated line from the + # input image. If the line replication factor is greater than + # 1 then simply repeat the input line. This algorithm is + # sequential in both the input and output image though the + # input image will be recycled for each repetition of higher + # dimensions. + + while (impnls (out, buf2, Meml[v2]) != EOF) { + # Get the input vector corresponding to the output line. + do i = 2, ndim + Meml[v1+i-1] = (Meml[v3+i-1] - 1) / blkfac[i] + 1 + i = imgnls (in, buf1, Meml[v1]) + + # Block replicate the columns. + if (blkfac[1] == 1) + buf3 = buf1 + else { + ptrin = buf1 + ptrout = buf + do i = 1, nin { + do j = 1, blkfac[1] { + Mems[ptrout] = Mems[ptrin] + ptrout = ptrout + 1 + } + ptrin = ptrin + 1 + } + buf3 = buf + } + + # Copy the input line to the output line. + call amovs (Mems[buf3], Mems[buf2], nout) + + # Repeat for each repetition of the input line. + for (i=2; i <= blkfac[2]; i=i+1) { + j = impnls (out, buf2, Meml[v2]) + call amovs (Mems[buf3], Mems[buf2], nout) + } + + call amovl (Meml[v2], Meml[v3], IM_MAXDIM) + } + } + + call sfree (sp) +end + diff --git a/pkg/images/imgeom/src/generic/im3dtran.x b/pkg/images/imgeom/src/generic/im3dtran.x new file mode 100644 index 00000000..ae3153fe --- /dev/null +++ b/pkg/images/imgeom/src/generic/im3dtran.x @@ -0,0 +1,583 @@ + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3s (a, b, nx, ny, nz) + +short a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3i (a, b, nx, ny, nz) + +int a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3l (a, b, nx, ny, nz) + +long a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3r (a, b, nx, ny, nz) + +real a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3d (a, b, nx, ny, nz) + +double a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3x (a, b, nx, ny, nz) + +complex a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + + diff --git a/pkg/images/imgeom/src/generic/imtrans.x b/pkg/images/imgeom/src/generic/imtrans.x new file mode 100644 index 00000000..26754fe6 --- /dev/null +++ b/pkg/images/imgeom/src/generic/imtrans.x @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2s (a, b, nx, ny) + +short a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2i (a, b, nx, ny) + +int a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2l (a, b, nx, ny) + +long a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2r (a, b, nx, ny) + +real a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2d (a, b, nx, ny) + +double a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2x (a, b, nx, ny) + +complex a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + + diff --git a/pkg/images/imgeom/src/generic/mkpkg b/pkg/images/imgeom/src/generic/mkpkg new file mode 100644 index 00000000..9fe8f222 --- /dev/null +++ b/pkg/images/imgeom/src/generic/mkpkg @@ -0,0 +1,13 @@ +# Library for the GEOMETRIC TRANSFORMATION tasks + +$checkout libpkg.a pkg$images/ +$update libpkg.a +$checkin libpkg.a pkg$images/ +$exit + +libpkg.a: + blkav.x + blkrp.x + imtrans.x + im3dtran.x + ; diff --git a/pkg/images/imgeom/src/im3dtran.gx b/pkg/images/imgeom/src/im3dtran.gx new file mode 100644 index 00000000..1b683124 --- /dev/null +++ b/pkg/images/imgeom/src/im3dtran.gx @@ -0,0 +1,98 @@ +$for (silrdx) + +# TXYZ3 -- Generic 3d transpose, x->x, y->y, z->z. The arrays need not be +# identical. + +procedure txyz3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[nx, ny, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, y, z] = a[x, y, z] +end + + +# TXZY3 -- Generic 3d transpose, x->x, y->z, z->y. The arrays need not be +# identical. + +procedure txzy3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[nx, nz, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[x, z, y] = a[x, y, z] +end + + +# TYXZ3 -- Generic 3d transpose, x->y, y->x, z->z. The arrays need not be +# identical. + +procedure tyxz3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[ny, nx, nz] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, x, z] = a[x, y, z] +end + + +# TYZX3 -- Generic 3d transpose, x->y, y->z, z->x. The arrays need not be +# identical. + +procedure tyzx3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[ny, nz, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[y, z, x] = a[x, y, z] +end + + +# TZXY3 -- Generic 3d transpose, x->z, y->x, z->y. The arrays need not be +# identical. + +procedure tzxy3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[nz, nx, ny] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, x, y] = a[x, y, z] +end + + +# TZYX3 -- Generic 3d transpose, x->z, y->y, z->x. The arrays need not be +# identical. + +procedure tzyx3$t (a, b, nx, ny, nz) + +PIXEL a[nx, ny, nz], b[nz, ny, nx] +int nx, ny, nz, x, y, z + +begin + do x = 1, nx + do y = 1, ny + do z = 1, nz + b[z, y, x] = a[x, y, z] +end + +$endfor diff --git a/pkg/images/imgeom/src/imtrans.gx b/pkg/images/imgeom/src/imtrans.gx new file mode 100644 index 00000000..3749e314 --- /dev/null +++ b/pkg/images/imgeom/src/imtrans.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$for (silrdx) + +# IMTR2 -- Generic transpose. The arrays need not be identical. + +procedure imtr2$t (a, b, nx, ny) + +PIXEL a[nx, ny], b[ny, nx] +int nx, ny, x, y + +begin + do x = 1, nx + do y = 1, ny + b[y, x] = a[x, y] +end + +$endfor diff --git a/pkg/images/imgeom/src/mkpkg b/pkg/images/imgeom/src/mkpkg new file mode 100644 index 00000000..2e784d54 --- /dev/null +++ b/pkg/images/imgeom/src/mkpkg @@ -0,0 +1,35 @@ +# Library for the GEOMETRIC TRANSFORMATION tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/blkav.x, blkav.gx) + $(GEN) blkav.gx -o generic/blkav.x $endif + $ifolder (generic/blkrp.x, blkrp.gx) + $(GEN) blkrp.gx -o generic/blkrp.x $endif + $ifolder (generic/imtrans.x, imtrans.gx) + $(GEN) imtrans.gx -o generic/imtrans.x $endif + $ifolder (generic/im3dtran.x, im3dtran.gx) + $(GEN) im3dtran.gx -o generic/im3dtran.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + blkcomp.x + shiftlines.x + t_blkavg.x + t_blkrep.x + t_imshift.x + t_imtrans.x + t_im3dtran.x + t_magnify.x + t_shiftlines.x + ; diff --git a/pkg/images/imgeom/src/shiftlines.x b/pkg/images/imgeom/src/shiftlines.x new file mode 100644 index 00000000..e0bd6d9a --- /dev/null +++ b/pkg/images/imgeom/src/shiftlines.x @@ -0,0 +1,279 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define NMARGIN 3 + +# SH_LINES -- Shift image lines. +# +# If an integer shift is given then do an efficient integer shift +# without datatype I/O conversions and using array move operators. +# If the shift is non-integer then use image interpolation. + +procedure sh_lines (im1, im2, shift, boundary, constant, interpstr) + +pointer im1 # Input image descriptor +pointer im2 # Output image descriptor +real shift # Shift in pixels +int boundary # Boundary extension type +real constant # Constant boundary extension +char interpstr[ARB] # Interpolation type + +int i, nsinc, nincr, ncols, nimcols, nlines, nbpix, nmargin, interpolation +long v1[IM_MAXDIM], v2[IM_MAXDIM], vout[IM_MAXDIM] +real dx, deltax, cx +pointer sp, x, asi, junk, buf1, buf2 + +bool fp_equalr() +int imggsr(), impnlr(), asigeti() + +begin + # Check for out of bounds shifts. + ncols = IM_LEN(im1, 1) + if (shift < -ncols || shift > ncols) + call error (0, "SHIFTLINES: Shift out of bounds") + + # Compute the shift. + dx = abs (shift - int (shift)) + if (fp_equalr (dx, 0.0)) + deltax = 0.0 + else if (shift > 0.0) + deltax = 1.0 - dx + else + deltax = dx + + # Initialize the interpolation. + call asitype (interpstr, interpolation, nsinc, nincr, cx) + if (interpolation == II_LSINC || interpolation == II_SINC) + call asisinit (asi, II_LSINC, nsinc, 1, deltax - nint (deltax), + 0.0) + else + call asisinit (asi, interpolation, nsinc, 1, cx, 0.0) + + # Set up the image boundary conditions. + if (interpolation == II_SINC || interpolation == II_LSINC) + nmargin = asigeti (asi, II_ASINSINC) + else + nmargin = NMARGIN + nbpix = int (abs (shift) + 1.0) + nmargin + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Allocate space for and set up the interpolation coordinates. + call smark (sp) + call salloc (x, 2 * ncols, TY_REAL) + deltax = deltax + nmargin + if (interpolation == II_DRIZZLE) { + do i = 1, ncols { + Memr[x+2*i-2] = i + deltax - 0.5 + Memr[x+2*i-1] = i + deltax + 0.5 + } + } else { + do i = 1, ncols + Memr[x+i-1] = i + deltax + } + + # Initialize the input v vectors. + cx = 1. - nmargin - shift + if ((cx <= 0.0) && (! fp_equalr (dx, 0.0))) + v1[1] = long (cx) - 1 + else + v1[1] = long (cx) + v2[1] = ncols - shift + nmargin + 1 + nimcols = v2[1] - v1[1] + 1 + do i = 2, IM_NDIM(im1) { + v1[i] = long (1) + v2[i] = long (1) + } + + # Compute the number of output lines. + nlines = 1 + do i = 2, IM_NDIM(im1) + nlines = nlines * IM_LEN(im1, i) + + # Initialize the output v vector. + call amovkl (long(1), vout, IM_MAXDIM) + + # Shift the images. + do i = 1, nlines { + + # Get the input image data buffer. + buf1 = imggsr (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "SHIFTLINES: Error reading input image\n") + + # Get the output image data buffer. + junk = impnlr (im2, buf2, vout) + if (junk == EOF) + call error (0, "SHIFTLINES: Error writing output image\n") + + # Evaluate the interpolation at the shifted points. + call asifit (asi, Memr[buf1], nimcols) + call asivector (asi, Memr[x], Memr[buf2], ncols) + + # Increment the v vectors. + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + call asifree (asi) + call sfree (sp) +end + + +# SH_LINESI -- Integer pixel shift. +# +# Shift the pixels in an image by an integer amount. Perform I/O without +# out type conversion and use array move operators. + +procedure sh_linesi (im1, im2, shift, boundary, constant) + +pointer im1 # Input image descriptor +pointer im2 # Output image descriptor +int shift # Integer shift +int boundary # Boundary extension type +real constant # Constant for boundary extension + +int i, ncols, nlines, junk +long v1[IM_MAXDIM], v2[IM_MAXDIM], vout[IM_MAXDIM] +pointer buf1, buf2 + +int imggss(), imggsi(), imggsl(), imggsr(), imggsd(), imggsx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() + +begin + # Set the boundary extension parameters. + call imseti (im1, IM_NBNDRYPIX, abs (shift)) + call imseti (im1, IM_TYBNDRY, boundary) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Return if shift off image. + ncols = IM_LEN(im1, 1) + if (shift < -ncols || shift > ncols) + call error (0, "Shiftlinesi: shift out of bounds") + + # Setup start vector for sequential reads and writes. + v1[1] = max (-ncols + 1, -shift + 1) + v2[1] = min (2 * ncols, ncols - shift) + do i = 2, IM_NDIM(im1) { + v1[i] = long (1) + v2[i] = long (1) + } + call amovkl (long(1), vout, IM_MAXDIM) + + # Setup line counter. + nlines = 1 + do i = 2, IM_NDIM(im1) + nlines = nlines * IM_LEN(im1, i) + + + # Shift the image using appropriate datatype operators. + switch (IM_PIXTYPE(im1)) { + + case TY_SHORT: + do i = 1, nlines { + buf1 = imggss (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnls (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovs (Mems[buf1], Mems[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + case TY_INT: + do i = 1, nlines { + buf1 = imggsi (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnli (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovi (Memi[buf1], Memi[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + case TY_LONG: + do i = 1, nlines { + buf1 = imggsl (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnll (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovl (Meml[buf1], Meml[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + case TY_REAL: + do i = 1, nlines { + buf1 = imggsr (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnlr (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovr (Memr[buf1], Memr[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + case TY_DOUBLE: + do i = 1, nlines { + buf1 = imggsd (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnld (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovd (Memd[buf1], Memd[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + case TY_COMPLEX: + do i = 1, nlines { + buf1 = imggsx (im1, v1, v2, IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Shiftlines: error reading input image") + junk = impnlx (im2, buf2, vout) + if (junk == EOF) + call error (0, "Shiftlinesi: error writing out image") + call amovx (Memx[buf1], Memx[buf2], ncols) + call sh_loop (v1, v2, IM_LEN(im1,1), IM_NDIM(im1)) + } + + default: + call error (0, "Unknown pixel datatype") + } +end + + +# SH_LOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). Return LOOP_DONE +# when V exceeds VE. + +procedure sh_loop (vs, ve, szdims, ndim) + +long vs[ndim] # the start vector +long ve[ndim] # the end vector +long szdims[ndim] # the dimensions vector +int ndim # the number of dimensions + +int dim + +begin + for (dim=2; dim <= ndim; dim=dim+1) { + vs[dim] = vs[dim] + 1 + ve[dim] = vs[dim] + if (vs[dim] - szdims[dim] == 1) { + if (dim < ndim) { + vs[dim] = 1 + ve[dim] = 1 + } else + break + } else + break + } +end diff --git a/pkg/images/imgeom/src/t_blkavg.x b/pkg/images/imgeom/src/t_blkavg.x new file mode 100644 index 00000000..e621bc64 --- /dev/null +++ b/pkg/images/imgeom/src/t_blkavg.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define OPTIONS "|average|sum|" # Values of task param options +define AVG 1 # Arithmetic average in block +define SUM 2 # Sum of pixels within block +define DEF_BLKFAC 1 # Default blocking factor + +# T_BLKAVG -- Block average or sum on n-dimensional images. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and are ignored in the output +# images. If the input and output image names are the same then the +# blocking operation is performed to a temporary file which then replaces +# the input image. + +procedure t_blkavg() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +int option # Type of operation +int blkfac[IM_MAXDIM] # Block sizes + +char image1[SZ_FNAME] # Input image name +char image2[SZ_FNAME] # Output image name +char imtemp[SZ_FNAME] # Temporary file + +int list1, list2, i +pointer im1, im2, mw +real shifts[IM_MAXDIM], mags[IM_MAXDIM] + +bool envgetb() +int imtopen(), imtgetim(), imtlen(), clgeti(), clgwrd() +pointer immap(), mw_openim() + +string blk_param "bX" + +begin + # Get input and output image template lists and the block sizes. + + call clgstr ("input", imtlist1, SZ_LINE) + call clgstr ("output", imtlist2, SZ_LINE) + option = clgwrd ("option", image1, SZ_FNAME, OPTIONS) + call amovki (INDEFI, blkfac, IM_MAXDIM) + + # Expand the input and output image lists. + + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + # Do each set of input/output images. + + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + do i = 1, IM_NDIM(im1) { + if (IS_INDEFI(blkfac[i])) { + call sprintf (blk_param[2], SZ_CHAR, "%1d") + call pargi (i) + blkfac[i] = max (1, min (clgeti (blk_param), + IM_LEN(im1, i))) + } + } + + # Perform the block operation. + switch (IM_PIXTYPE (im1)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call blkavl (im1, im2, blkfac, option) + case TY_REAL: + call blkavr (im1, im2, blkfac, option) + case TY_DOUBLE: + call blkavd (im1, im2, blkfac, option) + case TY_COMPLEX: + #call blkavx (im1, im2, blkfac, option) + call error (0, + "Blkavg does not currently support pixel data type complex.") + default: + call error (0, "Unknown pixel data type") + } + + # Update the world coordinate system. + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + do i = 1, IM_NDIM(im1) + mags[i] = 1.0d0 / double (blkfac[i]) + call mw_scale (mw, mags, (2 ** IM_NDIM(im1) - 1)) + do i = 1, IM_NDIM(im1) + shifts[i] = 0.5d0 - 1.0d0 / double (blkfac[i]) / 2.0d0 + call mw_shift (mw, shifts, (2 ** IM_NDIM(im1) - 1)) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + call imunmap (im2) + call imunmap (im1) + + call xt_delimtemp (image2, imtemp) + } + + call imtclose (list1) + call imtclose (list2) +end diff --git a/pkg/images/imgeom/src/t_blkrep.x b/pkg/images/imgeom/src/t_blkrep.x new file mode 100644 index 00000000..2f92a567 --- /dev/null +++ b/pkg/images/imgeom/src/t_blkrep.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# T_BLKREP -- Block replicate n-dimensional images. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and are ignored in the output +# images. If the input and output image names are the same then the +# replication operation is performed to a temporary file which then replaces +# the input image. + +procedure t_blkrep() + +int i, list1, list2 +pointer sp, image1, image2, image3, blkfac, im1, im2, mw +real shifts[IM_MAXDIM], mags[IM_MAXDIM] + +bool envgetb() +int imtopenp(), imtgetim(), imtlen(), clgeti() +pointer immap(), mw_openim() +string blk_param "bX" + +begin + # Allocate memory. + call smark (sp) + call salloc (image1, SZ_LINE, TY_CHAR) + call salloc (image2, SZ_LINE, TY_CHAR) + call salloc (image3, SZ_LINE, TY_CHAR) + call salloc (blkfac, IM_MAXDIM, TY_INT) + + # Expand the input and output image lists. + + list1 = imtopenp ("input") + list2 = imtopenp ("output") + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output images not the same") + } + + # Do each set of input/output images. + + call amovki (INDEFI, Memi[blkfac], IM_MAXDIM) + while ((imtgetim (list1, Memc[image1], SZ_LINE) != EOF) && + (imtgetim (list2, Memc[image2], SZ_LINE) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[image3], SZ_LINE) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + do i = 1, IM_NDIM(im1) { + if (IS_INDEFI(Memi[blkfac+i-1])) { + call sprintf (blk_param[2], SZ_CHAR, "%1d") + call pargi (i) + Memi[blkfac+i-1] = clgeti (blk_param) + } + } + + # Perform the block operation. + switch (IM_PIXTYPE (im1)) { + case TY_SHORT: + call blkrps (im1, im2, Memi[blkfac]) + case TY_INT, TY_LONG: + call blkrpl (im1, im2, Memi[blkfac]) + case TY_DOUBLE: + call blkrpd (im1, im2, Memi[blkfac]) + default: + call blkrpr (im1, im2, Memi[blkfac]) + } + + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + do i = 1, IM_NDIM(im1) + mags[i] = double (Memi[blkfac+i-1]) + call mw_scale (mw, mags, (2 ** IM_NDIM(im1) - 1)) + do i = 1, IM_NDIM(im1) + shifts[i] = 0.5d0 - double (Memi[blkfac+i-1]) / 2.0d0 + call mw_shift (mw, shifts, (2 ** IM_NDIM(im1) - 1)) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + call imunmap (im2) + call imunmap (im1) + + call xt_delimtemp (Memc[image2], Memc[image3]) + } + + call imtclose (list1) + call imtclose (list2) + call sfree (sp) +end diff --git a/pkg/images/imgeom/src/t_im3dtran.x b/pkg/images/imgeom/src/t_im3dtran.x new file mode 100644 index 00000000..46d4a536 --- /dev/null +++ b/pkg/images/imgeom/src/t_im3dtran.x @@ -0,0 +1,719 @@ +include +include +include + + +# Define all possible tranpose operations. +define XYZ 1 # xyz -> xyz +define XZY 2 # xyz -> xzy +define YXZ 3 # xyz -> yxz +define YZX 4 # xyz -> yzx +define ZXY 5 # xyz -> zxy +define ZYX 6 # xyz -> zyx + + +# T_IM3DTRAN -- Transpose 3d images. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and are ignored in the output +# images. If the input and output image names are the same then the transpose +# is performed to a temporary file which then replaces the input image. + +procedure t_im3dtran () + +bool verbose +int list1, list2, len_blk, new_ax[3], which3d +pointer sp, imtlist1, imtlist2, image1, image2, imtemp, im1, im2, mw + +bool clgetb(), envgetb() +int clgeti(), imtopen(), imtgetim(), imtlen(), whichtran() +pointer immap(), mw_openim() +errchk im3dtranpose(), mw_openim(), mw_saveim(), mw_close(), im3dtrmw() + +begin + # Get some working space. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + + # Get input and output image template lists, the size of the transpose + # block, and the transpose mapping. + call clgstr ("input", Memc[imtlist1], SZ_LINE) + call clgstr ("output", Memc[imtlist2], SZ_LINE) + new_ax[1] = clgeti ("new_x") + new_ax[2] = clgeti ("new_y") + new_ax[3] = clgeti ("new_z") + len_blk = clgeti ("len_blk") + verbose = clgetb ("verbose") + + # Determine the type of 3d transpose. + which3d = whichtran (new_ax) + if (which3d <= 0) + call error (0, "Invalid mapping of new_x, new_y, or new_z") + + # Expand the input and output image lists. + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output images not the same") + } + + # Do each set of input/output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + + if (verbose) { + call printf ( + "Image: %s axes: [123] -> Image: %s axes: [%d%d%d]\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image2]) + call pargi (new_ax[1]) + call pargi (new_ax[2]) + call pargi (new_ax[3]) + call flush (STDOUT) + } + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + iferr { + + # Do the transpose. + call im3dtranspose (im1, im2, len_blk, which3d, new_ax) + + # Update the image WCS to reflect the transpose. + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + call im3dtrmw (mw, which3d) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + } then { + + call eprintf ("Error transposing image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im2) + call imunmap (im1) + call imdelete (Memc[image2]) + + } else { + + # Finish up + call imunmap (im2) + call imunmap (im1) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + + call sfree (sp) +end + + +# IM3DTRANSPOSE -- Transpose a 3D image. +# +# Divide the image into square blocks of size len_blk by len_blk. +# Transpose each block with a generic array transpose operator. + +procedure im3dtranspose (im_in, im_out, len_blk, which3d, new_ax) + +pointer im_in #I Input image descriptor +pointer im_out #I Output image descriptor +int len_blk #I 1D length of transpose block +int which3d #I Parameterized transpose order +int new_ax[3] #I Map old axis[index] to new value + +int x1, x2, nx, y1, y2, ny, z1, z2, nz +pointer buf_in, buf_out +pointer imgs3s(), imps3s(), imgs3i(), imps3i(), imgs3l(), imps3l() +pointer imgs3r(), imps3r(), imgs3d(), imps3d(), imgs3x(), imps3x() + +begin + # Check that the image is 3D. + if (IM_NDIM(im_in) != 3) + call error (1, "image is not 3D.") + + # Output image is a copy of input image with dimensions transposed. + + IM_LEN (im_out, 1) = IM_LEN (im_in, new_ax[1]) + IM_LEN (im_out, 2) = IM_LEN (im_in, new_ax[2]) + IM_LEN (im_out, 3) = IM_LEN (im_in, new_ax[3]) + + # Break the input image into blocks of at most (len_blk) ** 3. + + do x1 = 1, IM_LEN (im_in, 1), len_blk { + x2 = x1 + len_blk - 1 + if (x2 > IM_LEN(im_in, 1)) + x2 = IM_LEN(im_in, 1) + nx = x2 - x1 + 1 + + do y1 = 1, IM_LEN (im_in, 2), len_blk { + y2 = y1 + len_blk - 1 + if (y2 > IM_LEN(im_in, 2)) + y2 = IM_LEN(im_in, 2) + ny = y2 - y1 + 1 + + do z1 = 1, IM_LEN (im_in, 3), len_blk { + z2 = z1 + len_blk - 1 + if (z2 > IM_LEN(im_in, 3)) + z2 = IM_LEN(im_in, 3) + nz = z2 - z1 + 1 + + # Switch on the pixel type to optimize IMIO. + + switch (IM_PIXTYPE (im_in)) { + + case TY_SHORT: + buf_in = imgs3s (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3s (im_out, x1, x2, y1, y2, z1, z2) + call txyz3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3s (im_out, x1, x2, z1, z2, y1, y2) + call txzy3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3s (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3s (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3s (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3s (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3s (Mems[buf_in], Mems[buf_out], nx,ny,nz) + } + + case TY_INT: + buf_in = imgs3i (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3i (im_out, x1, x2, y1, y2, z1, z2) + call txyz3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3i (im_out, x1, x2, z1, z2, y1, y2) + call txzy3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3i (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3i (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3i (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3i (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3i (Memi[buf_in], Memi[buf_out], nx,ny,nz) + } + + case TY_LONG, TY_USHORT: + buf_in = imgs3l (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3l (im_out, x1, x2, y1, y2, z1, z2) + call txyz3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3l (im_out, x1, x2, z1, z2, y1, y2) + call txzy3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3l (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3l (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3l (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3l (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3l (Meml[buf_in], Meml[buf_out], nx,ny,nz) + } + + case TY_REAL: + buf_in = imgs3r (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3r (im_out, x1, x2, y1, y2, z1, z2) + call txyz3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3r (im_out, x1, x2, z1, z2, y1, y2) + call txzy3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3r (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3r (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3r (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3r (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3r (Memr[buf_in], Memr[buf_out], nx,ny,nz) + } + + case TY_DOUBLE: + buf_in = imgs3d (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3d (im_out, x1, x2, y1, y2, z1, z2) + call txyz3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3d (im_out, x1, x2, z1, z2, y1, y2) + call txzy3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3d (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3d (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3d (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3d (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3d (Memd[buf_in], Memd[buf_out], nx,ny,nz) + } + + case TY_COMPLEX: + buf_in = imgs3x (im_in, x1, x2, y1, y2, z1, z2) + switch (which3d) { + case XYZ: + buf_out = imps3x (im_out, x1, x2, y1, y2, z1, z2) + call txyz3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + case XZY: + buf_out = imps3x (im_out, x1, x2, z1, z2, y1, y2) + call txzy3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + case YXZ: + buf_out = imps3x (im_out, y1, y2, x1, x2, z1, z2) + call tyxz3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + case YZX: + buf_out = imps3x (im_out, y1, y2, z1, z2, x1, x2) + call tyzx3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + case ZXY: + buf_out = imps3x (im_out, z1, z2, x1, x2, y1, y2) + call tzxy3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + case ZYX: + buf_out = imps3x (im_out, z1, z2, y1, y2, x1, x2) + call tzyx3x (Memx[buf_in], Memx[buf_out], nx,ny,nz) + } + + default: + call error (3, "unknown pixel type") + } + } + } + } +end + + +# WHICHTRAN -- Return the transpose type given the axes transpose list. + +int procedure whichtran (new_ax) + +int new_ax[3] #I the input axes transpose list. + +int which + +begin + which = 0 + + if (new_ax[1] == 1) { + if (new_ax[2] == 2) + which = XYZ + else if (new_ax[2] == 3) + which = XZY + } else if (new_ax[1] == 2) { + if (new_ax[2] == 1) + which = YXZ + else if (new_ax[2] == 3) + which = YZX + } else if (new_ax[1] == 3) { + if (new_ax[2] == 1) + which = ZXY + else if (new_ax[2] == 2) + which = ZYX + } + + return (which) +end + + +define LTM Memd[ltr+(($2)-1)*pdim+($1)-1] +define NCD Memd[ncd+(($2)-1)*pdim+($1)-1] +define swap {temp=$1;$1=$2;$2=temp} + +# IM3DTRMW -- Perform a transpose operation on the image WCS. + +procedure im3dtrmw (mw, which3d) + +pointer mw #I pointer to the mwcs structure +int which3d #I type of 3D transpose + +int i, axes[IM_MAXDIM], axval[IM_MAXDIM] +int naxes, pdim, nelem, axmap, ax1, ax2, ax3, szatstr +pointer sp, ltr, ltm, ltv, cd, r, w, ncd, nr +pointer attribute1, attribute2, attribute3, atstr1, atstr2, atstr3, mwtmp +double temp +int mw_stati(), itoc(), strlen() +pointer mw_open() +errchk mw_gwattrs(), mw_newsystem() + +begin + # Convert axis bitflags to the axis lists. + call mw_gaxlist (mw, 07B, axes, naxes) + if (naxes < 2) + return + + # Get the dimensions of the wcs and turn off axis mapping. + pdim = mw_stati (mw, MW_NPHYSDIM) + nelem = pdim * pdim + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + szatstr = SZ_LINE + + # Allocate working space. + call smark (sp) + call salloc (ltr, nelem, TY_DOUBLE) + call salloc (cd, nelem, TY_DOUBLE) + call salloc (r, pdim, TY_DOUBLE) + call salloc (w, pdim, TY_DOUBLE) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv, pdim, TY_DOUBLE) + call salloc (ncd, nelem, TY_DOUBLE) + call salloc (nr, pdim, TY_DOUBLE) + call salloc (attribute1, SZ_FNAME, TY_CHAR) + call salloc (attribute2, SZ_FNAME, TY_CHAR) + call salloc (attribute3, SZ_FNAME, TY_CHAR) + + # Get the wterm which corresponds to the original logical to + # world transformation. + call mw_gwtermd (mw, Memd[r], Memd[w], Memd[cd], pdim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], pdim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], pdim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], pdim) + call mwinvertd (Memd[ltm], Memd[ltr], pdim) + call mwmmuld (Memd[cd], Memd[ltr], Memd[ncd], pdim) + + # Define which physical axes the logical axes correspond to. + # and recompute the above wterm to take into account the transpose. + ax1 = axes[1] + ax2 = axes[2] + ax3 = axes[3] + + switch (which3d) { + case XYZ: + # do nothing + + case XZY: + # switch axes 3 and 2 + call amovd (Memd[ncd], Memd[ltr], nelem) + NCD(ax1,ax1) = LTM(ax1,ax1) + NCD(ax2,ax1) = LTM(ax3,ax1) + NCD(ax3,ax1) = LTM(ax2,ax1) + NCD(ax1,ax2) = LTM(ax1,ax3) + NCD(ax2,ax2) = LTM(ax3,ax3) + NCD(ax3,ax2) = LTM(ax2,ax3) + NCD(ax1,ax3) = LTM(ax1,ax2) + NCD(ax2,ax3) = LTM(ax3,ax2) + NCD(ax3,ax3) = LTM(ax2,ax2) + swap (Memd[w+ax3-1], Memd[w+ax2-1]) + swap (Memd[nr+ax3-1], Memd[nr+ax2-1]) + + case YXZ: + # switch axes 1 and 2 + call amovd (Memd[ncd], Memd[ltr], nelem) + NCD(ax1,ax1) = LTM(ax2,ax2) + NCD(ax2,ax1) = LTM(ax1,ax2) + NCD(ax3,ax1) = LTM(ax3,ax2) + NCD(ax1,ax2) = LTM(ax2,ax1) + NCD(ax2,ax2) = LTM(ax1,ax1) + NCD(ax3,ax2) = LTM(ax3,ax1) + NCD(ax1,ax3) = LTM(ax2,ax3) + NCD(ax2,ax3) = LTM(ax1,ax3) + NCD(ax3,ax3) = LTM(ax3,ax3) + swap (Memd[w+ax1-1], Memd[w+ax2-1]) + swap (Memd[nr+ax1-1], Memd[nr+ax2-1]) + + case YZX: + # map axes 123 to 231 + call amovd (Memd[ncd], Memd[ltr], nelem) + NCD(ax1,ax1) = LTM(ax2,ax2) + NCD(ax2,ax1) = LTM(ax3,ax2) + NCD(ax3,ax1) = LTM(ax1,ax2) + NCD(ax1,ax2) = LTM(ax2,ax3) + NCD(ax2,ax2) = LTM(ax3,ax3) + NCD(ax3,ax2) = LTM(ax1,ax3) + NCD(ax1,ax3) = LTM(ax2,ax1) + NCD(ax2,ax3) = LTM(ax3,ax1) + NCD(ax3,ax3) = LTM(ax1,ax1) + call amovd (Memd[w], Memd[ltv], pdim) + Memd[w+ax1-1] = Memd[ltv+ax2-1] + Memd[w+ax2-1] = Memd[ltv+ax3-1] + Memd[w+ax3-1] = Memd[ltv+ax1-1] + call amovd (Memd[nr], Memd[ltv], pdim) + Memd[nr+ax1-1] = Memd[ltv+ax2-1] + Memd[nr+ax2-1] = Memd[ltv+ax3-1] + Memd[nr+ax3-1] = Memd[ltv+ax1-1] + + case ZXY: + # map axes 123 to 312 + call amovd (Memd[ncd], Memd[ltr], nelem) + NCD(ax1,ax1) = LTM(ax3,ax3) + NCD(ax2,ax1) = LTM(ax1,ax3) + NCD(ax3,ax1) = LTM(ax2,ax3) + NCD(ax1,ax2) = LTM(ax3,ax1) + NCD(ax2,ax2) = LTM(ax1,ax1) + NCD(ax3,ax2) = LTM(ax2,ax1) + NCD(ax1,ax3) = LTM(ax3,ax2) + NCD(ax2,ax3) = LTM(ax1,ax2) + NCD(ax3,ax3) = LTM(ax2,ax2) + call amovd (Memd[w], Memd[ltv], pdim) + Memd[w+ax1-1] = Memd[ltv+ax3-1] + Memd[w+ax2-1] = Memd[ltv+ax1-1] + Memd[w+ax3-1] = Memd[ltv+ax2-1] + call amovd (Memd[nr], Memd[ltv], pdim) + Memd[nr+ax1-1] = Memd[ltv+ax3-1] + Memd[nr+ax2-1] = Memd[ltv+ax1-1] + Memd[nr+ax3-1] = Memd[ltv+ax2-1] + + case ZYX: + # switch axes 3 and 1 + call amovd (Memd[ncd], Memd[ltr], nelem) + NCD(ax1,ax1) = LTM(ax3,ax3) + NCD(ax2,ax1) = LTM(ax2,ax3) + NCD(ax3,ax1) = LTM(ax1,ax3) + NCD(ax1,ax2) = LTM(ax3,ax2) + NCD(ax2,ax2) = LTM(ax2,ax2) + NCD(ax3,ax2) = LTM(ax1,ax2) + NCD(ax1,ax3) = LTM(ax3,ax1) + NCD(ax2,ax3) = LTM(ax2,ax1) + NCD(ax3,ax3) = LTM(ax1,ax1) + swap (Memd[w+ax1-1], Memd[w+ax3-1]) + swap (Memd[nr+ax1-1], Memd[nr+ax3-1]) + } + + # Perform the transpose of the lterm. + call mw_mkidmd (Memd[ltr], pdim) + switch (which3d) { + + case XYZ: + # do nothing + + case XZY: + # switch axes 3 and 2 + LTM(ax2,ax2) = 0.0d0 + LTM(ax3,ax2) = 1.0d0 + LTM(ax2,ax3) = 1.0d0 + LTM(ax3,ax3) = 0.0d0 + + case YXZ: + # switch axes 1 and 2 + LTM(ax1,ax1) = 0.0d0 + LTM(ax1,ax2) = 1.0d0 + LTM(ax2,ax1) = 1.0d0 + LTM(ax2,ax2) = 0.0d0 + + case YZX: + # map axes 123 to 231 + LTM(ax1,ax1) = 0.0d0 + LTM(ax1,ax2) = 1.0d0 + LTM(ax1,ax3) = 0.0d0 + LTM(ax2,ax1) = 0.0d0 + LTM(ax2,ax2) = 0.0d0 + LTM(ax2,ax3) = 1.0d0 + LTM(ax3,ax1) = 1.0d0 + LTM(ax3,ax2) = 0.0d0 + LTM(ax3,ax3) = 0.0d0 + + case ZXY: + # map axes 123 to 312 + LTM(ax1,ax1) = 0.0d0 + LTM(ax1,ax2) = 0.0d0 + LTM(ax1,ax3) = 1.0d0 + LTM(ax2,ax1) = 1.0d0 + LTM(ax2,ax2) = 0.0d0 + LTM(ax2,ax3) = 0.0d0 + LTM(ax3,ax1) = 0.0d0 + LTM(ax3,ax2) = 1.0d0 + LTM(ax3,ax3) = 0.0d0 + + case ZYX: + # switch axes 3 and 1 + LTM(ax3,ax3) = 0.0d0 + LTM(ax3,ax1) = 1.0d0 + LTM(ax1,ax3) = 1.0d0 + LTM(ax1,ax1) = 0.0d0 + + } + call aclrd (Memd[ltv], pdim) + call aclrd (Memd[r], pdim) + call mw_translated (mw, Memd[ltv], Memd[ltr], Memd[r], pdim) + + # Get the new lterm, recompute the wterm, and store it. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], pdim) + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], pdim) + call mwinvertd (Memd[ltm], Memd[ltr], pdim) + call asubd (Memd[nr], Memd[ltv], Memd[r], pdim) + call mwvmuld (Memd[ltr], Memd[r], Memd[nr], pdim) + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[cd], pdim) + + # Make a new temporary wcs and set the system name. + mwtmp = mw_open (NULL, pdim) + call mw_gsystem (mw, Memc[attribute1], SZ_FNAME) + iferr (call mw_newsystem (mwtmp, Memc[attribute1], pdim)) + call mw_ssystem (mwtmp, Memc[attribute1]) + + # Copy the wterm and the lterm to it. + call mw_gwtermd (mw, Memd[r], Memd[w], Memd[ltr], pdim) + call mw_swtermd (mwtmp, Memd[r], Memd[w], Memd[ltr], pdim) + call mw_gltermd (mw, Memd[ltr], Memd[r], pdim) + call mw_sltermd (mwtmp, Memd[ltr], Memd[r], pdim) + + # Set the axis map and the axis types. + call mw_gaxmap (mw, axes, axval, pdim) + call mw_saxmap (mwtmp, axes, axval, pdim) + iferr (call mw_gwattrs (mw, ax1, "wtype", Memc[attribute1], SZ_FNAME)) + call strcpy ("linear", Memc[attribute1], SZ_FNAME) + iferr (call mw_gwattrs (mw, ax2, "wtype", Memc[attribute2], SZ_FNAME)) + call strcpy ("linear", Memc[attribute2], SZ_FNAME) + iferr (call mw_gwattrs (mw, ax3, "wtype", Memc[attribute3], SZ_FNAME)) + call strcpy ("linear", Memc[attribute3], SZ_FNAME) + + switch (which3d) { + case XYZ: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute1], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute2], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute3], "") + case XZY: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute1], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute3], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute2], "") + case YXZ: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute2], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute1], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute3], "") + case YZX: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute2], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute3], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute1], "") + case ZXY: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute3], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute1], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute2], "") + case ZYX: + call mw_swtype (mwtmp, ax1, 1, Memc[attribute3], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute2], "") + call mw_swtype (mwtmp, ax3, 1, Memc[attribute1], "") + } + + # Copy the axis attributes. + call malloc (atstr1, szatstr, TY_CHAR) + call malloc (atstr2, szatstr, TY_CHAR) + call malloc (atstr3, szatstr, TY_CHAR) + + for (i = 1; ; i = i + 1) { + + if (itoc (i, Memc[attribute1], SZ_FNAME) <= 0) + Memc[attribute1] = EOS + if (itoc (i, Memc[attribute2], SZ_FNAME) <= 0) + Memc[attribute2] = EOS + if (itoc (i, Memc[attribute3], SZ_FNAME) <= 0) + Memc[attribute3] = EOS + + repeat { + iferr (call mw_gwattrs (mw, ax1, Memc[attribute1], + Memc[atstr1], szatstr)) + Memc[atstr1] = EOS + iferr (call mw_gwattrs (mw, ax2, Memc[attribute2], + Memc[atstr2], szatstr)) + Memc[atstr2] = EOS + iferr (call mw_gwattrs (mw, ax3, Memc[attribute3], + Memc[atstr3], szatstr)) + Memc[atstr3] = EOS + if ((strlen (Memc[atstr1]) < szatstr) && + (strlen (Memc[atstr2]) < szatstr) && + (strlen (Memc[atstr3]) < szatstr)) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr1, szatstr, TY_CHAR) + call realloc (atstr2, szatstr, TY_CHAR) + call realloc (atstr3, szatstr, TY_CHAR) + } + if ((Memc[atstr1] == EOS) && (Memc[atstr2] == EOS) && + (Memc[atstr3] == EOS)) + break + + switch (which3d) { + case XYZ: + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute1], Memc[atstr1]) + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute2], Memc[atstr2]) + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute3], Memc[atstr3]) + case XZY: + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute1], Memc[atstr1]) + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute3], Memc[atstr3]) + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute2], Memc[atstr2]) + case YXZ: + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute2], Memc[atstr2]) + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute1], Memc[atstr1]) + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute3], Memc[atstr3]) + case YZX: + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute2], Memc[atstr2]) + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute3], Memc[atstr3]) + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute1], Memc[atstr1]) + case ZXY: + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute3], Memc[atstr3]) + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute1], Memc[atstr1]) + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute2], Memc[atstr2]) + case ZYX: + if (Memc[atstr3] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute3], Memc[atstr3]) + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute2], Memc[atstr2]) + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax3, Memc[attribute1], Memc[atstr1]) + } + + } + call mfree (atstr1, TY_CHAR) + call mfree (atstr2, TY_CHAR) + call mfree (atstr3, TY_CHAR) + call mw_close (mw) + + # Delete the old wcs and set equal to the new one. + call sfree (sp) + mw = mwtmp + call mw_seti (mw, MW_USEAXMAP, axmap) +end diff --git a/pkg/images/imgeom/src/t_imshift.x b/pkg/images/imgeom/src/t_imshift.x new file mode 100644 index 00000000..4a940b99 --- /dev/null +++ b/pkg/images/imgeom/src/t_imshift.x @@ -0,0 +1,530 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +define NYOUT 16 # number of lines output at once +define NMARGIN 3 # number of boundary pixels required +define NMARGIN_SPLINE3 16 # number of spline boundary pixels required + + +# T_IMSHIFT -- Shift a 2-D image by an arbitrary amount in X and Y, using +# boundary extension to preserve the image size. + +procedure t_imshift() + +pointer imtlist1 # Input image list +pointer imtlist2 # Output image list + +pointer image1 # Input image +pointer image2 # Output image +pointer imtemp # Temporary file +pointer sfile # Text file containing list of shifts +pointer interpstr # Interpolant string + +int list1, list2, boundary_type, ixshift, iyshift, nshifts, interp_type +pointer sp, str, xs, ys, im1, im2, sf, mw +real constant, shifts[2] +double txshift, tyshift, xshift, yshift + +bool fp_equald(), envgetb() +int imtgetim(), imtlen(), clgwrd(), strdic(), open(), ish_rshifts() +pointer immap(), imtopen(), mw_openim() +real clgetr() +double clgetd() +errchk ish_ishiftxy, ish_gshiftxy, mw_openim, mw_saveim, mw_shift + +begin + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_LINE, TY_CHAR) + call salloc (image2, SZ_LINE, TY_CHAR) + call salloc (imtemp, SZ_LINE, TY_CHAR) + call salloc (sfile, SZ_FNAME, TY_CHAR) + call salloc (interpstr, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + call clgstr ("shifts_file", Memc[sfile], SZ_FNAME) + + # Get the 2-D interpolation parameters. + call clgstr ("interp_type", Memc[interpstr], SZ_FNAME) + interp_type = strdic (Memc[interpstr], Memc[str], SZ_LINE, + II_BFUNCTIONS) + boundary_type = clgwrd ("boundary_type", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + if (boundary_type == BT_CONSTANT) + constant = clgetr ("constant") + + # Open the input and output image lists. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Number of input and output images not the same.") + } + + # Determine the source of the shifts. + if (Memc[sfile] != EOS) { + sf = open (Memc[sfile], READ_ONLY, TEXT_FILE) + call salloc (xs, imtlen (list1), TY_DOUBLE) + call salloc (ys, imtlen (list1), TY_DOUBLE) + nshifts = ish_rshifts (sf, Memd[xs], Memd[ys], imtlen (list1)) + if (nshifts != imtlen (list1)) + call error (2, + "The number of input images and shifts are not the same.") + } else { + sf = NULL + txshift = clgetd ("xshift") + tyshift = clgetd ("yshift") + } + + + # Do each set of input and output images. + nshifts = 0 + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + + im1 = immap (Memc[image1], READ_ONLY, 0) + im2 = immap (Memc[image2], NEW_COPY, im1) + + if (sf != NULL) { + xshift = Memd[xs+nshifts] + yshift = Memd[ys+nshifts] + } else { + xshift = txshift + yshift = tyshift + } + + ixshift = int (xshift) + iyshift = int (yshift) + + iferr { + # Perform the shift. + if (interp_type == II_BINEAREST) { + call ish_ishiftxy (im1, im2, nint(xshift), nint(yshift), + boundary_type, constant) + } else if (fp_equald (xshift, double(ixshift)) && + fp_equald (yshift, double(iyshift))) { + call ish_ishiftxy (im1, im2, ixshift, iyshift, + boundary_type, constant) + } else { + call ish_gshiftxy (im1, im2, xshift, yshift, + Memc[interpstr], boundary_type, constant) + } + + # Update the image WCS to reflect the shift. + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + shifts[1] = xshift + shifts[2] = yshift + call mw_shift (mw, shifts, 03B) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + } then { + call eprintf ("Error shifting image: %s\n") + call pargstr (Memc[image1]) + call erract (EA_WARN) + call imunmap (im2) + call imunmap (im1) + call imdelete (Memc[image2]) + + } else { + # Finish up. + call imunmap (im2) + call imunmap (im1) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + nshifts = nshifts + 1 + } + + if (sf != NULL) + call close (sf) + call imtclose (list1) + call imtclose (list2) + call sfree (sp) +end + + +# ISH_ISHIFTXY -- Shift a 2-D image by integral pixels in x and y. + +procedure ish_ishiftxy (im1, im2, ixshift, iyshift, boundary_type, + constant) + +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int ixshift #I shift in x and y +int iyshift #I +int boundary_type #I type of boundary extension +real constant #I constant for boundary extension + +pointer buf1, buf2 +long v[IM_MAXDIM] +int ncols, nlines, nbpix +int i, x1col, x2col, yline + +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer imgs2s(), imgs2i(), imgs2l(), imgs2r(), imgs2d(), imgs2x() +errchk impnls, impnli, impnll, impnlr, impnld, impnlx +errchk imgs2s, imgs2i, imgs2l, imgs2r, imgs2d, imgs2x +string wrerr "ISHIFTXY: Error writing in image." + +begin + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Cannot shift off image. + if (ixshift < -ncols || ixshift > ncols) + call error (3, "ISHIFTXY: X shift out of bounds.") + if (iyshift < -nlines || iyshift > nlines) + call error (4, "ISHIFTXY: Y shift out of bounds.") + + # Calculate the shift. + switch (boundary_type) { + case BT_CONSTANT,BT_REFLECT,BT_NEAREST: + ixshift = min (ncols, max (-ncols, ixshift)) + iyshift = min (nlines, max (-nlines, iyshift)) + case BT_WRAP: + ixshift = mod (ixshift, ncols) + iyshift = mod (iyshift, nlines) + } + + # Set the boundary extension values. + nbpix = max (abs (ixshift), abs (iyshift)) + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Get column boundaries in the input image. + x1col = max (-ncols + 1, - ixshift + 1) + x2col = min (2 * ncols, ncols - ixshift) + + call amovkl (long (1), v, IM_MAXDIM) + + # Shift the image using the appropriate data type operators. + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + do i = 1, nlines { + if (impnls (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2s (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovs (Mems[buf1], Mems[buf2], ncols) + } + case TY_INT: + do i = 1, nlines { + if (impnli (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2i (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovi (Memi[buf1], Memi[buf2], ncols) + } + case TY_USHORT, TY_LONG: + do i = 1, nlines { + if (impnll (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2l (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovl (Meml[buf1], Meml[buf2], ncols) + } + case TY_REAL: + do i = 1, nlines { + if (impnlr (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2r (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovr (Memr[buf1], Memr[buf2], ncols) + } + case TY_DOUBLE: + do i = 1, nlines { + if (impnld (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2d (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovd (Memd[buf1], Memd[buf2], ncols) + } + case TY_COMPLEX: + do i = 1, nlines { + if (impnlx (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2x (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovx (Memx[buf1], Memx[buf2], ncols) + } + default: + call error (6, "ISHIFTXY: Unknown IRAF type.") + } +end + + +# ISH_GSHIFTXY -- Shift an image by fractional pixels in x and y. +# Unfortunately, this code currently performs the shift only on single +# precision real, so precision is lost if the data is of type double, +# and the imaginary component is lost if the data is of type complex. + +procedure ish_gshiftxy (im1, im2, xshift, yshift, interpstr, boundary_type, + constant) + +pointer im1 #I pointer to input image +pointer im2 #I pointer to output image +double xshift #I shift in x direction +double yshift #I shift in y direction +char interpstr[ARB] #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I value of constant for boundary extension + +int lout1, lout2, nyout, nxymargin, interp_type, nsinc, nincr +int cin1, cin2, nxin, lin1, lin2, nyin, i +int ncols, nlines, nbpix, fstline, lstline +double xshft, yshft, deltax, deltay, dx, dy, cx, ly +pointer sp, x, y, msi, sinbuf, soutbuf + +pointer imps2r() +int msigeti() +bool fp_equald() +errchk msisinit(), msifree(), msifit(), msigrid() +errchk imgs2r(), imps2r() + +begin + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Check for out of bounds shift. + if (xshift < -ncols || xshift > ncols) + call error (7, "GSHIFTXY: X shift out of bounds.") + if (yshift < -nlines || yshift > nlines) + call error (8, "GSHIFTXY: Y shift out of bounds.") + + # Get the real shift. + if (boundary_type == BT_WRAP) { + xshft = mod (xshift, real (ncols)) + yshft = mod (yshift, real (nlines)) + } else { + xshft = xshift + yshft = yshift + } + + # Allocate temporary space. + call smark (sp) + call salloc (x, 2 * ncols, TY_REAL) + call salloc (y, 2 * nlines, TY_REAL) + sinbuf = NULL + + # Define the x and y shifts for the interpolation. + dx = abs (xshft - int (xshft)) + if (fp_equald (dx, 0D0)) + deltax = 0.0 + else if (xshft > 0.) + deltax = 1. - dx + else + deltax = dx + dy = abs (yshft - int (yshft)) + if (fp_equald (dy, 0D0)) + deltay = 0.0 + else if (yshft > 0.) + deltay = 1. - dy + else + deltay = dy + + # Initialize the 2-D interpolation routines. + call msitype (interpstr, interp_type, nsinc, nincr, cx) + if (interp_type == II_BILSINC || interp_type == II_BISINC ) + call msisinit (msi, II_BILSINC, nsinc, 1, 1, + deltax - nint (deltax), deltay - nint (deltay), 0.0) + else + call msisinit (msi, interp_type, nsinc, nincr, nincr, cx, cx, 0.0) + + # Set boundary extension parameters. + if (interp_type == II_BISPLINE3) + nxymargin = NMARGIN_SPLINE3 + else if (interp_type == II_BISINC || interp_type == II_BILSINC) + nxymargin = msigeti (msi, II_MSINSINC) + else + nxymargin = NMARGIN + nbpix = max (int (abs(xshft)+1.0), int (abs(yshft)+1.0)) + nxymargin + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the x interpolation coordinates + deltax = deltax + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, ncols { + Memr[x+2*i-2] = i + deltax - 0.5 + Memr[x+2*i-1] = i + deltax + 0.5 + } + } else { + do i = 1, ncols + Memr[x+i-1] = i + deltax + } + + # Define the y interpolation coordinates. + deltay = deltay + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, NYOUT { + Memr[y+2*i-2] = i + deltay - 0.5 + Memr[y+2*i-1] = i + deltay + 0.5 + } + } else { + do i = 1, NYOUT + Memr[y+i-1] = i + deltay + } + + # Define column ranges in the input image. + cx = 1. - nxymargin - xshft + if ((cx <= 0.) && (! fp_equald (dx, 0D0))) + cin1 = int (cx) - 1 + else + cin1 = int (cx) + cin2 = ncols - xshft + nxymargin + 1 + nxin = cin2 - cin1 + 1 + + # Loop over output sections. + for (lout1 = 1; lout1 <= nlines; lout1 = lout1 + NYOUT) { + + # Define range of output lines. + lout2 = min (lout1 + NYOUT - 1, nlines) + nyout = lout2 - lout1 + 1 + + # Define correspoding range of input lines. + ly = lout1 - nxymargin - yshft + if ((ly <= 0.0) && (! fp_equald (dy, 0D0))) + lin1 = int (ly) - 1 + else + lin1 = int (ly) + lin2 = lout2 - yshft + nxymargin + 1 + nyin = lin2 - lin1 + 1 + + # Get appropriate input section and calculate the coefficients. + if ((sinbuf == NULL) || (lin1 < fstline) || (lin2 > lstline)) { + fstline = lin1 + lstline = lin2 + call ish_buf (im1, cin1, cin2, lin1, lin2, sinbuf) + call msifit (msi, Memr[sinbuf], nxin, nyin, nxin) + } + + # Output the section. + soutbuf = imps2r (im2, 1, ncols, lout1, lout2) + if (soutbuf == EOF) + call error (9, "GSHIFTXY: Error writing output image.") + + # Evaluate the interpolant. + call msigrid (msi, Memr[x], Memr[y], Memr[soutbuf], ncols, nyout, + ncols) + } + + if (sinbuf != NULL) + call mfree (sinbuf, TY_REAL) + + call msifree (msi) + call sfree (sp) +end + + +# ISH_BUF -- Provide a buffer of image lines with minimum reads. + +procedure ish_buf (im, col1, col2, line1, line2, buf) + +pointer im #I pointer to input image +int col1, col2 #I column range of input buffer +int line1, line2 #I line range of input buffer +pointer buf #U buffer + +pointer buf1, buf2 +int i, ncols, nlines, nclast, llast1, llast2, nllast +errchk malloc, realloc +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + # Make sure the buffer is large enough. + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + # The buffers must be contiguous. + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end + + +# ISH_RSHIFTS -- Read shifts from a file. + +int procedure ish_rshifts (fd, x, y, max_nshifts) + +int fd #I shifts file +double x[ARB] #O x array +double y[ARB] #O y array +int max_nshifts #I the maximum number of shifts + +int nshifts +int fscan(), nscan() + +begin + nshifts = 0 + while (fscan (fd) != EOF && nshifts < max_nshifts) { + call gargd (x[nshifts+1]) + call gargd (y[nshifts+1]) + if (nscan () != 2) + next + nshifts = nshifts + 1 + } + + return (nshifts) +end diff --git a/pkg/images/imgeom/src/t_imtrans.x b/pkg/images/imgeom/src/t_imtrans.x new file mode 100644 index 00000000..04fa1d61 --- /dev/null +++ b/pkg/images/imgeom/src/t_imtrans.x @@ -0,0 +1,299 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# T_IMTRANSPOSE -- Transpose images. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and are ignored in the output +# images. If the input and output image names are the same then the transpose +# is performed to a temporary file which then replaces the input image. + +procedure t_imtranspose () + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +int len_blk # 1D length of transpose block + +char image1[SZ_FNAME] # Input image name +char image2[SZ_FNAME] # Output image name +char imtemp[SZ_FNAME] # Temporary file + +int list1, list2 +pointer im1, im2, mw + +bool envgetb() +int clgeti(), imtopen(), imtgetim(), imtlen() +pointer immap(), mw_openim() + +begin + # Get input and output image template lists and the size of + # the transpose block. + + call clgstr ("input", imtlist1, SZ_LINE) + call clgstr ("output", imtlist2, SZ_LINE) + len_blk = clgeti ("len_blk") + + # Expand the input and output image lists. + + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + # Do each set of input/output images. + + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + # Do the transpose. + call imtranspose (im1, im2, len_blk) + + # Update the image WCS to reflect the shift. + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + call imtrmw (mw) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + # Unmap the input and output images. + call imunmap (im2) + call imunmap (im1) + + call xt_delimtemp (image2, imtemp) + } + + call imtclose (list1) + call imtclose (list2) +end + + +# IMTRANSPOSE -- Transpose an image. +# +# Divide the image into square blocks of size len_blk by len_blk. +# Transpose each block with a generic array transpose operator. + +procedure imtranspose (im_in, im_out, len_blk) + +pointer im_in # Input image descriptor +pointer im_out # Output image descriptor +int len_blk # 1D length of transpose block + +int x1, x2, nx +int y1, y2, ny +pointer buf_in, buf_out + +pointer imgs2s(), imps2s(), imgs2i(), imps2i(), imgs2l(), imps2l() +pointer imgs2r(), imps2r(), imgs2d(), imps2d(), imgs2x(), imps2x() + +begin + # Output image is a copy of input image with dims transposed. + + IM_LEN (im_out, 1) = IM_LEN (im_in, 2) + IM_LEN (im_out, 2) = IM_LEN (im_in, 1) + + # Break the input image into blocks of at most len_blk by len_blk. + + do x1 = 1, IM_LEN (im_in, 1), len_blk { + x2 = x1 + len_blk - 1 + if (x2 > IM_LEN(im_in, 1)) + x2 = IM_LEN(im_in, 1) + nx = x2 - x1 + 1 + + do y1 = 1, IM_LEN (im_in, 2), len_blk { + y2 = y1 + len_blk - 1 + if (y2 > IM_LEN(im_in, 2)) + y2 = IM_LEN(im_in, 2) + ny = y2 - y1 + 1 + + # Switch on the pixel type to optimize IMIO. + + switch (IM_PIXTYPE (im_in)) { + case TY_SHORT: + buf_in = imgs2s (im_in, x1, x2, y1, y2) + buf_out = imps2s (im_out, y1, y2, x1, x2) + call imtr2s (Mems[buf_in], Mems[buf_out], nx, ny) + case TY_INT: + buf_in = imgs2i (im_in, x1, x2, y1, y2) + buf_out = imps2i (im_out, y1, y2, x1, x2) + call imtr2i (Memi[buf_in], Memi[buf_out], nx, ny) + case TY_USHORT, TY_LONG: + buf_in = imgs2l (im_in, x1, x2, y1, y2) + buf_out = imps2l (im_out, y1, y2, x1, x2) + call imtr2l (Meml[buf_in], Meml[buf_out], nx, ny) + case TY_REAL: + buf_in = imgs2r (im_in, x1, x2, y1, y2) + buf_out = imps2r (im_out, y1, y2, x1, x2) + call imtr2r (Memr[buf_in], Memr[buf_out], nx, ny) + case TY_DOUBLE: + buf_in = imgs2d (im_in, x1, x2, y1, y2) + buf_out = imps2d (im_out, y1, y2, x1, x2) + call imtr2d (Memd[buf_in], Memd[buf_out], nx, ny) + case TY_COMPLEX: + buf_in = imgs2x (im_in, x1, x2, y1, y2) + buf_out = imps2x (im_out, y1, y2, x1, x2) + call imtr2x (Memx[buf_in], Memx[buf_out], nx, ny) + default: + call error (0, "unknown pixel type") + } + } + } +end + +define LTM Memd[ltr+(($2)-1)*pdim+($1)-1] +define NCD Memd[ncd+(($2)-1)*pdim+($1)-1] +define swap {temp=$1;$1=$2;$2=temp} + + +# IMTRMW -- Perform a transpose operation on the image WCS. + +procedure imtrmw (mw) + +pointer mw # pointer to the mwcs structure + +int i, axes[IM_MAXDIM], axval[IM_MAXDIM] +int naxes, pdim, nelem, axmap, ax1, ax2, szatstr +pointer sp, ltr, ltm, ltv, cd, r, w, ncd, nr +pointer attribute1, attribute2, atstr1, atstr2, mwtmp +double temp +int mw_stati(), itoc(), strlen() +pointer mw_open() +errchk mw_gwattrs(), mw_newsystem() + +begin + # Convert axis bitflags to the axis lists. + call mw_gaxlist (mw, 03B, axes, naxes) + if (naxes < 2) + return + + # Get the dimensions of the wcs and turn off axis mapping. + pdim = mw_stati (mw, MW_NPHYSDIM) + nelem = pdim * pdim + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + szatstr = SZ_LINE + + # Allocate working space. + call smark (sp) + call salloc (ltr, nelem, TY_DOUBLE) + call salloc (cd, nelem, TY_DOUBLE) + call salloc (r, pdim, TY_DOUBLE) + call salloc (w, pdim, TY_DOUBLE) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv, pdim, TY_DOUBLE) + call salloc (ncd, nelem, TY_DOUBLE) + call salloc (nr, pdim, TY_DOUBLE) + call salloc (attribute1, SZ_FNAME, TY_CHAR) + call salloc (attribute2, SZ_FNAME, TY_CHAR) + + # Get the wterm which corresponds to the original logical to + # world transformation. + call mw_gwtermd (mw, Memd[r], Memd[w], Memd[cd], pdim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], pdim) + call mwvmuld (Memd[ltm], Memd[r], Memd[nr], pdim) + call aaddd (Memd[nr], Memd[ltv], Memd[nr], pdim) + call mwinvertd (Memd[ltm], Memd[ltr], pdim) + call mwmmuld (Memd[cd], Memd[ltr], Memd[ncd], pdim) + + # Define which physical axes the logical axes correspond to. + # and recompute the above wterm to take into account the transpose. + ax1 = axes[1] + ax2 = axes[2] + swap (NCD(ax1,ax1), NCD(ax2,ax2)) + swap (NCD(ax1,ax2), NCD(ax2,ax1)) + swap (Memd[w+ax1-1], Memd[w+ax2-1]) + swap (Memd[nr+ax1-1], Memd[nr+ax2-1]) + + # Perform the transpose of the lterm. + call mw_mkidmd (Memd[ltr], pdim) + LTM(ax1,ax1) = 0.0d0 + LTM(ax1,ax2) = 1.0d0 + LTM(ax2,ax1) = 1.0d0 + LTM(ax2,ax2) = 0.0d0 + call aclrd (Memd[ltv], pdim) + call aclrd (Memd[r], pdim) + call mw_translated (mw, Memd[ltv], Memd[ltr], Memd[r], pdim) + + # Get the new lterm, recompute the wterm, and store it. + call mw_gltermd (mw, Memd[ltm], Memd[ltv], pdim) + call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], pdim) + call mwinvertd (Memd[ltm], Memd[ltr], pdim) + call asubd (Memd[nr], Memd[ltv], Memd[r], pdim) + call mwvmuld (Memd[ltr], Memd[r], Memd[nr], pdim) + call mw_swtermd (mw, Memd[nr], Memd[w], Memd[cd], pdim) + + # Make a new temporary wcs and set the system name. + mwtmp = mw_open (NULL, pdim) + call mw_gsystem (mw, Memc[attribute1], SZ_FNAME) + iferr (call mw_newsystem (mwtmp, Memc[attribute1], pdim)) + call mw_ssystem (mwtmp, Memc[attribute1]) + + # Copy the wterm and the lterm to it. + call mw_gwtermd (mw, Memd[r], Memd[w], Memd[ltr], pdim) + call mw_swtermd (mwtmp, Memd[r], Memd[w], Memd[ltr], pdim) + call mw_gltermd (mw, Memd[ltr], Memd[r], pdim) + call mw_sltermd (mwtmp, Memd[ltr], Memd[r], pdim) + + # Set the axis map and the axis types. + call mw_gaxmap (mw, axes, axval, pdim) + call mw_saxmap (mwtmp, axes, axval, pdim) + iferr (call mw_gwattrs (mw, ax1, "wtype", Memc[attribute1], SZ_FNAME)) + call strcpy ("linear", Memc[attribute1], SZ_FNAME) + iferr (call mw_gwattrs (mw, ax2, "wtype", Memc[attribute2], SZ_FNAME)) + call strcpy ("linear", Memc[attribute2], SZ_FNAME) + call mw_swtype (mwtmp, ax1, 1, Memc[attribute2], "") + call mw_swtype (mwtmp, ax2, 1, Memc[attribute1], "") + + # Copy the axis attributes. + call malloc (atstr1, szatstr, TY_CHAR) + call malloc (atstr2, szatstr, TY_CHAR) + for (i = 1; ; i = i + 1) { + + if (itoc (i, Memc[attribute1], SZ_FNAME) <= 0) + Memc[attribute1] = EOS + if (itoc (i, Memc[attribute2], SZ_FNAME) <= 0) + Memc[attribute2] = EOS + + repeat { + iferr (call mw_gwattrs (mw, ax1, Memc[attribute1], + Memc[atstr1], szatstr)) + Memc[atstr1] = EOS + iferr (call mw_gwattrs (mw, ax2, Memc[attribute2], + Memc[atstr2], szatstr)) + Memc[atstr2] = EOS + if ((strlen (Memc[atstr1]) < szatstr) && + (strlen (Memc[atstr2]) < szatstr)) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr1, szatstr, TY_CHAR) + call realloc (atstr2, szatstr, TY_CHAR) + } + if ((Memc[atstr1] == EOS) && (Memc[atstr2] == EOS)) + break + + if (Memc[atstr2] != EOS) + call mw_swattrs (mwtmp, ax1, Memc[attribute2], Memc[atstr2]) + if (Memc[atstr1] != EOS) + call mw_swattrs (mwtmp, ax2, Memc[attribute1], Memc[atstr1]) + } + call mfree (atstr1, TY_CHAR) + call mfree (atstr2, TY_CHAR) + call mw_close (mw) + + # Delete the old wcs and set equal to the new one. + call sfree (sp) + mw = mwtmp + call mw_seti (mw, MW_USEAXMAP, axmap) +end diff --git a/pkg/images/imgeom/src/t_magnify.x b/pkg/images/imgeom/src/t_magnify.x new file mode 100644 index 00000000..ed797500 --- /dev/null +++ b/pkg/images/imgeom/src/t_magnify.x @@ -0,0 +1,624 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# T_MAGNIFY -- Change coordinate origin and pixel interval in 2D images. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and ignored in the output +# images. If the input and output image names are the same then the +# magnification is performed to a temporary file which then replaces +# the input image. + +# Interpolation types and boundary extension types. + +define BTYPES "|constant|nearest|reflect|wrap|project|" +define SZ_BTYPE 8 + +procedure t_magnify () + +pointer input # Pointer to input image list +pointer output # Pointer to output image list +pointer interp # Pointer to image interpolation type +pointer boundary # Pointer to boundary extension type +real bconst # Boundary extension pixel value +real xmag, ymag # Image magnifications +real dx, dy # Step size +real x1, y1 # Starting coordinates +real x2, y2 # Ending coordinates +int flux # Flux conserve + +int list1, list2, btype, logfd +pointer sp, in, out, image1, image2, image3, mw, errmsg +real a, b, c, d, shifts[2], scale[2] + +bool clgetb(), envgetb(), fp_equalr() +int clgwrd(), imtopen(), imtgetim(), imtlen(), open(), btoi(), errget() +pointer mw_openim(), immap() +real clgetr() +errchk open(), mg_magnify1(), mg_magnify2() + +begin + call smark (sp) + call salloc (input, SZ_LINE, TY_CHAR) + call salloc (output, SZ_LINE, TY_CHAR) + call salloc (interp, SZ_FNAME, TY_CHAR) + call salloc (boundary, SZ_BTYPE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (image3, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_FNAME, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[input], SZ_LINE) + call clgstr ("output", Memc[output], SZ_LINE) + call clgstr ("interpolation", Memc[interp], SZ_FNAME) + btype = clgwrd ("boundary", Memc[boundary], SZ_BTYPE, BTYPES) + bconst = clgetr ("constant") + a = clgetr ("x1") + b = clgetr ("x2") + dx = clgetr ("dx") + c = clgetr ("y1") + d = clgetr ("y2") + dy = clgetr ("dy") + flux = btoi (clgetb ("fluxconserve")) + + # If the pixel interval INDEF then use the a magnification factor + # to determine the pixel interval. + + if (IS_INDEF (dx)) { + xmag = clgetr ("xmag") + if (xmag < 0.0) + dx = -xmag + else if (xmag > 0.0) + dx = 1.0 / xmag + else + dx = 0.0 + } + + if (IS_INDEF (dy)) { + ymag = clgetr ("ymag") + if (ymag < 0.0) + dy = -ymag + else if (ymag > 0.0) + dy = 1.0 / ymag + else + dy = 0.0 + } + + if (fp_equalr (dx, 0.0) || fp_equalr (dy, 0.0)) { + call error (0, "Illegal magnification") + } else { + xmag = 1.0 / dx + ymag = 1.0 / dy + } + + + # Open the log file. + call clgstr ("logfile", Memc[image1], SZ_FNAME) + iferr (logfd = open (Memc[image1], APPEND, TEXT_FILE)) + logfd = NULL + + # Expand the input and output image lists. + list1 = imtopen (Memc[input]) + list2 = imtopen (Memc[output]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + # Magnify each set of input/output images with the 2D interpolation + # package. + + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + # Map the input and output images. + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[image3], + SZ_FNAME) + in = immap (Memc[image1], READ_ONLY, 0) + out = immap (Memc[image2], NEW_COPY, in) + + # Set the limits of the output image. + x1 = a + x2 = b + y1 = c + y2 = d + + # Magnify the image making sure to update the wcs. + iferr { + if (IM_NDIM(in) == 1) { + call mg_magnify1 (in, out, Memc[interp], btype, bconst, + x1, x2, dx, flux) + if (!envgetb ("nomwcs")) { + mw = mw_openim (in) + scale[1] = xmag + shifts[1] = 1. - xmag * x1 + call mw_scale (mw, scale, 01B) + call mw_shift (mw, shifts, 01B) + call mw_saveim (mw, out) + call mw_close (mw) + } + } else if (IM_NDIM(in) == 2) { + call mg_magnify2 (in, out, Memc[interp], btype, bconst, + x1, x2, dx, y1, y2, dy, flux) + if (!envgetb ("nomwcs")) { + mw = mw_openim (in) + scale[1] = xmag + scale[2] = ymag + shifts[1] = 1. - xmag * x1 + shifts[2] = 1. - ymag * y1 + call mw_scale (mw, scale, 03B) + call mw_shift (mw, shifts, 03B) + call mw_saveim (mw, out) + call mw_close (mw) + } + } else { + call imunmap (out) + call imunmap (in) + call xt_delimtemp (Memc[image2], Memc[image3]) + if (logfd != NULL) { + call fprintf (logfd, "\n%s\n") + call pargstr (Memc[image3]) + call fprintf (logfd, + " Cannot magnify image %s to image %s.\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + call fprintf (logfd, + " Dimensions are greater than 2.\n") + } + call imdelete (Memc[image3]) + next + } + + } then { + if (logfd != NULL) { + call fprintf (logfd, "\n%s\n") + call pargstr (Memc[image3]) + call fprintf (logfd, + " Cannot magnify image %s to image %s.\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + if (errget (Memc[errmsg], SZ_FNAME) <= 0) + ; + call fprintf (logfd, "%s") + call pargstr (Memc[errmsg]) + } + call imdelete (Memc[image3]) + call imunmap (out) + call imunmap (in) + call xt_delimtemp (Memc[image2], Memc[image3]) + } else { + + if (logfd != NULL) { + call fprintf (logfd, "\n%s\n") + call pargstr (Memc[image3]) + call fprintf (logfd, " Magnify image %s to image %s.\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + call fprintf (logfd, " Interpolation is %s.\n") + call pargstr (Memc[interp]) + call fprintf (logfd, " Boundary extension is %s.\n") + call pargstr (Memc[boundary]) + if (btype == 1) { + call fprintf (logfd, + " Boundary pixel constant is %g.\n") + call pargr (bconst) + } + call fprintf (logfd, + " Output coordinates in terms of input coordinates:\n") + call fprintf (logfd, + " x1 = %10.4g, x2 = %10.4g, dx = %10.6g\n") + call pargr (x1) + call pargr (x2) + call pargr (dx) + if (IM_NDIM(in) == 2) { + call fprintf (logfd, + " y1 = %10.4g, y2 = %10.4g, dy = %10.6g\n") + call pargr (y1) + call pargr (y2) + call pargr (dy) + } + } + + call imunmap (out) + call imunmap (in) + call xt_delimtemp (Memc[image2], Memc[image3]) + } + + } + + call imtclose (list1) + call imtclose (list2) + call close (logfd) + call sfree (sp) +end + + +define NYOUT2 16 # Number of input lines to use for interpolation +define NMARGIN 3 # Number of edge lines to add for interpolation +define NMARGIN_SPLINE3 16 # Number of edge lines to add for interpolation + + +# MG_MAGNIFY1 -- Magnify the input input image to create the output image. + +procedure mg_magnify1 (in, out, interp, btype, bconst, x1, x2, dx, flux) + +pointer in # pointer to the input image +pointer out # pointer to the output image +char interp[ARB] # Interpolation type +int btype # Boundary extension type +real bconst # Boundary extension constant +real x1, x2 # Starting and ending points of output image +real dx # Pixel interval +int flux # Conserve flux? + +int i, nxin, nxout, nxymargin, itype, nsinc, nincr, col1, col2 +pointer sp, x, z, buf, asi +real xshift +pointer imgs1r(), impl1r() +int asigeti() + +begin + # Set the default values for the output image limits if they are INDEF + # and calculate the number of output pixels. + + if (IS_INDEF (x1)) + x1 = 1. + if (IS_INDEF (x2)) + x2 = IM_LEN (in, 1) + if (x1 > x2) + call error (0, " X1 cannot be greater than X2\n") + + # Set the number of output pixels in the image header. + + nxout = (x2 - x1) / dx + 1 + IM_LEN(out, 1) = nxout + + # Initialize the interpolator. + + call asitype (interp, itype, nsinc, nincr, xshift) + call asisinit (asi, itype, nsinc, nincr, xshift, 0.0) + + # Round the coordinate limits to include the output image coordinate + # limits and the set boundary. + + col1 = x1 + col2 = nint (x2) + if (itype == II_SPLINE3) + nxymargin = NMARGIN_SPLINE3 + else if (itype == II_SINC || itype == II_LSINC) + nxymargin = asigeti (asi, II_ASINSINC) + else if (itype == II_DRIZZLE) + nxymargin = max (nint (dx), NMARGIN) + else + nxymargin = NMARGIN + call mg_setboundary1 (in, col1, col2, btype, bconst, nxymargin) + col1 = col1 - nxymargin + if (col1 <= 0) + col1 = col1 - 1 + col2 = col2 + nxymargin + 1 + + # Allocate memory for the interpolation coordinates. + # Also initialize the image data buffer. + + call smark (sp) + call salloc (x, 2 * nxout, TY_REAL) + + # Set the x interpolation coordinates. The coordinates are relative + # to the boundary extended input image. + + if (itype == II_DRIZZLE) { + do i = 1, nxout { + Memr[x+2*i-2] = x1 + (i - 1.5) * dx - col1 + 1 + Memr[x+2*i-1] = x1 + (i - 0.5) * dx - col1 + 1 + } + } else { + do i = 1, nxout + Memr[x+i-1] = x1 + (i - 1) * dx - col1 + 1 + } + + # Fit the output image. + nxin = col2 - col1 + 1 + buf = imgs1r (in, col1, col2) + call asifit (asi, Memr[buf], nxin) + + # Evaluate the output image pixel values. + z = impl1r (out) + call asivector (asi, Memr[x], Memr[z], nxout) + #if (itype != II_DRIZZLE && flux == YES) + if (flux == YES) + call amulkr (Memr[z], dx, Memr[z], nxout) + + # Free memory and unmap the images. + call asifree (asi) + call sfree (sp) +end + + +# MG_MAGNIFY2 -- Magnify the input input image to create the output image. + +procedure mg_magnify2 (in, out, interp, btype, bconst, x1, x2, dx, y1, y2, + dy, flux) + +pointer in # pointer to the input image +pointer out # pointer to the output image +char interp[ARB] # Interpolation type +int btype # Boundary extension type +real bconst # Boundary extension constant +real x1, y1 # Starting point of output image +real x2, y2 # Ending point of output image +real dx, dy # Pixel interval +int flux # Conserve flux? + +int i, nxin, nxout, nyout, nxymargin, itype, nsinc, nincr +int l1out, l2out, nlout, l1in, l2in, nlin, fstline, lstline +int col1, col2, line1, line2 +real shift +pointer msi +pointer sp, x, y, z, buf + +pointer imps2r() +int msigeti() + +begin + # Set the default values for the output image limits if they are INDEF + # and calculate the number of output pixels. + + if (IS_INDEF (x1)) + x1 = 1. + if (IS_INDEF (x2)) + x2 = IM_LEN (in, 1) + if (IS_INDEF (y1)) + y1 = 1. + if (IS_INDEF (y2)) + y2 = IM_LEN (in, 2) + if (x1 > x2) + call error (0, " X1 cannot be greater than X2\n") + if (y1 > y2) + call error (0, " Y1 cannot be greater than Y2\n") + nxout = (x2 - x1) / dx + 1 + nyout = (y2 - y1) / dy + 1 + + # Set the number of output pixels in the image header. + + IM_LEN(out, 1) = nxout + IM_LEN(out, 2) = nyout + + # Initialize the interpolator. + + call msitype (interp, itype, nsinc, nincr, shift) + call msisinit (msi, itype, nsinc, nincr, nincr, shift, shift, 0.0) + + # Compute the number of margin pixels required + + if (itype == II_BISPLINE3) + nxymargin = NMARGIN_SPLINE3 + else if (itype == II_BISINC || itype == II_BILSINC) + nxymargin = msigeti (msi, II_MSINSINC) + else if (itype == II_BIDRIZZLE) + nxymargin = max (nint (dx), nint(dy), NMARGIN) + else + nxymargin = NMARGIN + + # Round the coordinate limits to include the output image coordinate + # limits and the set boundary. + + col1 = x1 + col2 = nint (x2) + line1 = y1 + line2 = nint (y2) + call mg_setboundary2 (in, col1, col2, line1, line2, btype, bconst, + nxymargin) + + # Compute the input image column limits. + col1 = col1 - nxymargin + if (col1 <= 0) + col1 = col1 - 1 + col2 = col2 + nxymargin + 1 + nxin = col2 - col1 + 1 + + # Allocate memory for the interpolation coordinates. + # Also initialize the image data buffer. + + call smark (sp) + call salloc (x, 2 * nxout, TY_REAL) + call salloc (y, 2 * NYOUT2, TY_REAL) + buf = NULL + fstline = 0 + lstline = 0 + + # Set the x interpolation coordinates which do not change from + # line to line. The coordinates are relative to the boundary + # extended input image. + + if (itype == II_BIDRIZZLE) { + do i = 1, nxout { + Memr[x+2*i-2] = x1 + (i - 1.5) * dx - col1 + 1 + Memr[x+2*i-1] = x1 + (i - 0.5) * dx - col1 + 1 + } + } else { + do i = 1, nxout + Memr[x+i-1] = x1 + (i - 1) * dx - col1 + 1 + } + + # Loop over the image sections. + for (l1out = 1; l1out <= nyout; l1out = l1out + NYOUT2) { + + # Define the range of output lines. + l2out = min (l1out + NYOUT2 - 1, nyout) + nlout = l2out - l1out + 1 + + # Define the corresponding range of input lines. + l1in = y1 + (l1out - 1) * dy - nxymargin + if (l1in <= 0) + l1in = l1in - 1 + l2in = y1 + (l2out - 1) * dy + nxymargin + 1 + nlin = l2in - l1in + 1 + + # Get the apporiate image section and compute the coefficients. + if ((buf == NULL) || (l1in < fstline) || (l2in > lstline)) { + fstline = l1in + lstline = l2in + call mg_bufl2r (in, col1, col2, l1in, l2in, buf) + call msifit (msi, Memr[buf], nxin, nlin, nxin) + } + + # Output the section. + z = imps2r (out, 1, nxout, l1out, l2out) + + # Compute the y values. + if (itype == II_BIDRIZZLE) { + do i = l1out, l2out { + Memr[y+2*(i-l1out)] = y1 + (i - 1.5) * dy - fstline + 1 + Memr[y+2*(i-l1out)+1] = y1 + (i - 0.5) * dy - fstline + 1 + } + } else { + do i = l1out, l2out + Memr[y+i-l1out] = y1 + (i - 1) * dy - fstline + 1 + } + + # Evaluate the interpolant. + call msigrid (msi, Memr[x], Memr[y], Memr[z], nxout, nlout, nxout) + if (flux == YES) + call amulkr (Memr[z], dx * dy, Memr[z], nxout * nlout) + } + + # Free memory and buffers. + call msifree (msi) + call mfree (buf, TY_REAL) + call sfree (sp) +end + + +# MG_BUFL2R -- Maintain buffer of image lines. A new buffer is created when +# the buffer pointer is null or if the number of lines requested is changed. +# The minimum number of image reads is used. + +procedure mg_bufl2r (im, col1, col2, line1, line2, buf) + +pointer im # Image pointer +int col1 # First image column of buffer +int col2 # Last image column of buffer +int line1 # First image line of buffer +int line2 # Last image line of buffer +pointer buf # Buffer + +int i, ncols, nlines, nclast, llast1, llast2, nllast +pointer buf1, buf2 + +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + # If the buffer pointer is undefined then allocate memory for the + # buffer. If the number of columns or lines requested changes + # reallocate the buffer. Initialize the last line values to force + # a full buffer image read. + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + # Read only the image lines with are different from the last buffer. + + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + # Save the buffer parameters. + + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end + + +# MG_SETBOUNDARY1 -- Set boundary extension for a 1D image. + +procedure mg_setboundary1 (im, col1, col2, btype, bconst, nxymargin) + +pointer im # IMIO pointer +int col1, col2 # Range of columns +int btype # Boundary extension type +real bconst # Constant for constant boundary extension +int nxymargin # Number of margin pixels + +int btypes[5] +int nbndrypix + +data btypes /BT_CONSTANT, BT_NEAREST, BT_REFLECT, BT_WRAP, BT_PROJECT/ + +begin + nbndrypix = 0 + nbndrypix = max (nbndrypix, 1 - col1) + nbndrypix = max (nbndrypix, col2 - IM_LEN(im, 1)) + + call imseti (im, IM_TYBNDRY, btypes[btype]) + call imseti (im, IM_NBNDRYPIX, nbndrypix + nxymargin + 1) + if (btypes[btype] == BT_CONSTANT) + call imsetr (im, IM_BNDRYPIXVAL, bconst) +end + + +# MG_SETBOUNDARY2 -- Set boundary extension for a 2D image. + +procedure mg_setboundary2 (im, col1, col2, line1, line2, btype, bconst, + nxymargin) + +pointer im # IMIO pointer +int col1, col2 # Range of columns +int line1, line2 # Range of lines +int btype # Boundary extension type +real bconst # Constant for constant boundary extension +int nxymargin # Number of margin pixels to allow + +int btypes[5] +int nbndrypix + +data btypes /BT_CONSTANT, BT_NEAREST, BT_REFLECT, BT_WRAP, BT_PROJECT/ + +begin + nbndrypix = 0 + nbndrypix = max (nbndrypix, 1 - col1) + nbndrypix = max (nbndrypix, col2 - IM_LEN(im, 1)) + nbndrypix = max (nbndrypix, 1 - line1) + nbndrypix = max (nbndrypix, line2 - IM_LEN(im, 2)) + + call imseti (im, IM_TYBNDRY, btypes[btype]) + call imseti (im, IM_NBNDRYPIX, nbndrypix + nxymargin + 1) + if (btypes[btype] == BT_CONSTANT) + call imsetr (im, IM_BNDRYPIXVAL, bconst) +end diff --git a/pkg/images/imgeom/src/t_shiftlines.x b/pkg/images/imgeom/src/t_shiftlines.x new file mode 100644 index 00000000..36ce5dec --- /dev/null +++ b/pkg/images/imgeom/src/t_shiftlines.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# T_SHIFTLINES -- Shift image lines. +# +# The input and output images are given by image template lists. The +# number of output images must match the number of input images. Image +# sections are allowed in the input images and are ignored in the output +# images. If the input and output image names are the same then the shift +# is performed to a temporary file which then replaces the input image. + + +procedure t_shiftlines() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +real shift # Amount of pixel shift +int boundary # Type of boundary extension +real constant # Constant for boundary extension + +char image1[SZ_FNAME] # Input image name +char image2[SZ_FNAME] # Output image name +char imtemp[SZ_FNAME] # Temporary file + +char str[SZ_LINE], interpstr[SZ_FNAME] +int list1, list2, ishift +pointer im1, im2, mw + +bool fp_equalr(), envgetb() +int clgwrd(), imtopen(), imtgetim(), imtlen() +pointer immap(), mw_openim() +real clgetr() +errchk sh_lines, sh_linesi, mw_openim, mw_shift, mw_saveim, mw_close + +begin + # Get input and output image template lists. + call clgstr ("input", imtlist1, SZ_LINE) + call clgstr ("output", imtlist2, SZ_LINE) + + # Get the shift, interpolation type, and boundary condition. + shift = clgetr ("shift") + call clgstr ("interp_type", interpstr, SZ_LINE) + boundary = clgwrd ("boundary_type", str, SZ_LINE, + ",constant,nearest,reflect,wrap,") + constant = clgetr ("constant") + + # Expand the input and output image lists. + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + ishift = shift + + # Do each set of input/output images. + while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && + (imtgetim (list2, image2, SZ_FNAME) != EOF)) { + + call xt_mkimtemp (image1, image2, imtemp, SZ_FNAME) + + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + # Shift the image. + iferr { + + if (fp_equalr (shift, real (ishift))) + call sh_linesi (im1, im2, ishift, boundary, constant) + else + call sh_lines (im1, im2, shift, boundary, constant, + interpstr) + + # Update the image WCS to reflect the shift. + if (!envgetb ("nomwcs")) { + mw = mw_openim (im1) + call mw_shift (mw, shift, 1B) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + } then { + call eprintf ("Error shifting image: %s\n") + call pargstr (image1) + call erract (EA_WARN) + } + + # Unmap images. + call imunmap (im2) + call imunmap (im1) + + # If in place operation replace the input image with the temporary + # image. + call xt_delimtemp (image2, imtemp) + } + + call imtclose (list1) + call imtclose (list2) +end diff --git a/pkg/images/immatch/Revisions b/pkg/images/immatch/Revisions new file mode 100644 index 00000000..a45cc7be --- /dev/null +++ b/pkg/images/immatch/Revisions @@ -0,0 +1,2025 @@ +.help revisions Jan97 images.immatch +.nf +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/immatch/doc/geomap.hlp b/pkg/images/immatch/doc/geomap.hlp new file mode 100644 index 00000000..525e70b8 --- /dev/null +++ b/pkg/images/immatch/doc/geomap.hlp @@ -0,0 +1,435 @@ +.help geomap Jan01 images.immatch +.ih +NAME +geomap -- compute one or more spatial transformation functions +.ih +USAGE +geomap input database xmin xmax ymin ymax +.ih +PARAMETERS +.ls input +The list of text files containing the pixel coordinates of control points in +the reference and input images. The control points are listed +one per line with xref, yref, xin, and yin in columns 1 through 4 respectively. +.le +.ls database +The name of the text file database where the computed transformations will +be stored. +.le +.ls xmin, xmax, ymin, ymax +The range of reference coordinates over which the computed coordinate +transformation is valid. If the user is working in pixel units these limits +should normally be set to the values of the column and row limits of the +reference image, e.g xmin = 1.0, xmax = 512, ymin= 1.0, ymax = 512 for +a 512 x 512 image. The minimum and maximum xref and yref values in \fIinput\fR +are used if xmin, xmax, ymin, or ymax are undefined. +.le +.ls transforms = "" +An optional list of transform record names. If transforms is undefined +the database record(s) are assigned the names of the +individual text files specified by \fIinput\fR. +.le +.ls results = "" +Optional output files containing a summary of the results including a +description of the transform geometry and a listing of the input coordinates, +the fitted coordinates, and the fit residuals. The number of results files +must be one or equal to the number of input files. If results is "STDOUT" the + results summary is printed on the standard output. +.le +.ls fitgeometry = "general" +The fitting geometry to be used. The options are the following. +.ls shift +X and y shifts only are fit. +.le +.ls xyscale +X and y shifts and x and y magnification factors are fit. Axis flips are +allowed for. +.le +.ls rotate +X and y shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +X and y shifts, a magnification factor assumed to be the same in x and y, and a +rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +X and y shifts, x and y magnifications factors, and a rotation angle are fit. +Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes an x and y +shift, an x and y scale factor, a rotation and a skew. Axis flips are also +allowed for in the linear portion of the fit. The distortion term consists +of a polynomial fit to the residuals of the linear term. By default the +distortion term is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are assumed to be "none", regardless of the values of the +\fIxxorder\fR, \fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR and +\fIyxterms\fR parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic surface to be fit. The options are the following. +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the x and y fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an x and y shift, +an x and y scale change, and rotations of the x and y axes. The "shift", +"xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is max (xxorder - 1, xyorder - 1) for the x fit and +max (yxorder - 1, yyorder - 1) for the y fit. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is max (xxorder - 1, xyorder - 1) for the x fit and +max (yxorder - 1, yyorder - 1) for the y fit. +.le + +The "shift", "xyscale", "rotation", "rscale", and "rxyscale" fitting +geometries, assume that the cross term switches are set to "none" +regardless of the values set by the user. If either of the cross terms +parameters are set to "half" or "full" and \fIfitgeometry\fR is "general" +then a distortion surface is fit to the residuals from the linear +portion of the fit. +.le +.ls maxiter = 0 +The maximum number of rejection iterations. The default is no rejection. +.le +.ls reject = 3.0 +The rejection limit in units of sigma. +.le +.ls calctype = "real" +The precision of the coordinate transformation calculations. The options are +real and double. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le +.ls interactive = yes +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, reject points, display the data, etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls cursor = "" +The graphics cursor. +.le +.ih +DESCRIPTION + +GEOMAP computes the transformation required to map the reference coordinate +system to the input coordinate system. The coordinates of points in common +to the two systems are listed in the input text file(s) \fIinput\fR +one per line in the following format: "xref yref xin yin". + +The computed transforms are stored in the text database file \fIdatabase\fR +in records with names specified by the parameter \fItransforms\fR. If the +transforms parameter is undefined the records are assigned the name of +the input coordinate files. + +The computed transformation has the form shown below, where the reference +coordinates must be defined in the coordinate system of the reference image +system if the user intends to resample an image with gregister or geotran, or +transform coordinates from the reference coordinate system to the input +image coordinate system. + +.nf + xin = f (xref, yref) + yin = g (xref, yref) +.fi + +If on the other hand the user wishes to transform coordinates from the +input image coordinate system to the reference coordinate system then he or she +must reverse the roles of the reference and input coordinates as defined above, +and compute the inverse transformation. + + +The functions f and g are either a power series polynomial or a Legendre or +Chebyshev polynomial surface of order \fIxxorder\fR and \fIxyorder\fR in x +and \fIyxorder\fR and \fIyyorder\fR in y. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a13' * yref ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a22 * xref * yref + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a22' * xref * yref + a13' * yref ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a31 * xref ** 2 + + a12 * yref + a22 * xref * yref + a32 * xref ** 2 * yref + + a13 * yref ** 2 + a23 * xref * yref ** 2 + + a33 * xref ** 2 * yref ** 2 + yin = a11' + a21' * xref + a31' * xref ** 2 + + a12' * yref + a22' * xref * yref + a32' * xref ** 2 * yref + + a13' * yref ** 2 + a23' * xref * yref ** 2 + + a33' * xref ** 2 * yref ** 2 +.fi + +If the \fBfitgeometry\fR parameter is anything other than "general", the order +parameters assume the value 2 and the cross terms switches assume the value +"none", regardless of the values set by the user. The computation can be done in +either real or double precision by setting \fIcalctype\fR. Automatic pixel +rejection may be enabled by setting \fmaxiter\fR > 0 and \fIreject\fR to some +number greater than 0. + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the region of +validity of the fit in the reference coordinate system and must be set by +the user. These parameters can be used to reject out of range data before the +actual fitting is done. + +GEOMAP may be run interactively by setting \fIinteractive\fR = yes and +inputting commands by the use of simple keystrokes. +In interactive mode the user has the option of changing the +fit parameters and displaying the data graphically until a satisfactory +fit has been achieved. The available keystroke commands are listed +below. + +.nf +? Print options +f Fit the data and graph with the current graph type (g, x, r, y, s) +g Graph the data and the current fit +x,r Graph the x fit residuals versus x and y respectively +y,s Graph the y fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the constant x, y plotting option +t Plot a line of constant x, y through the nearest data point +l Print xshift, yshift, xmag, ymag, xrotate, yrotate +q Exit the interactive curve fitting +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name alone will list the current value. + +.nf +:show List parameters +:fitgeometry Fitting geometry (shift,xyscale,rotate, + rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre, + polynomial) +:xxorder :xyorder [value] X fitting function xorder, yorder +:yxorder :yyorder [value] Y fitting function xorder, yorder +:xxterms :yxterms [n/h/f] X, Y fit cross terms type +:maxiter [value] Maximum number of rejection iterations +:reject [value] Rejection threshold +.fi + +The final fit is stored in a simple text file in a format suitable for use +by the GREGISTER or GEOTRAN tasks. + +If \fIverbose\fR is "yes", various pieces of useful information are printed +to the terminal as the task proceeds. If \fIresults\fR is set to a file name +then the input coordinates, the fitted coordinates, and the residuals of +the fit are written to that file. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not correspond to a physically meaningful model. However the computed +coefficients for the linear term can be given a simple geometrical geometric +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + + fitting geometry = shift + xin = a + xref + yin = d + yref + + fitting geometry = xyscale + xin = a + b * xref + yin = d + f * yref + + fitting geometry = rotate + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const +.fi + +The coefficients can be interpreted as follows. Xref0, yref0, xin0, yin0 +are the origins in the reference and input frames respectively. Orientation +and skew are the rotation of the x and y axes and their deviation from +perpendicularity respectively. Xmag and ymag are the scaling factors in x and +y and are assumed to be positive. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xin0 - xref0 = xshift + d = yin0 - yref0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xin0 - b * xref0 = xshift + d = yin0 - f * yref0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift +.fi + + +.ih +EXAMPLES +1. Compute the linear transformation between coordinate systems. + A record called "m51.coo" will be written in the database + file "database". + + +.nf + cl> geomap m51.coo database 1. 512. 1. 512. +.fi + +2. Compute the 3rd order transformation in x and y between two + coordinate systems. A record called "m51.coo" will be written in + the database file "database". This record supersedes the one + of the same name written in example 1. + +.nf + cl> geomap m51.coo database 1. 512. 1. 512. xxo=4 xyo=4 \ + >>> yxo=4 yyo=4 xxt=full yxt=full inter- +.fi + +3. Register a 500 by 500 image of m51 to an 800 by 800 image of the same +field taken with a different instrument, and display the original +800 by 800 image and the transformed image. Use the default fitting parameters. + +.nf + cl> geomap m51.coo database 1.0 800.0 1.0 800.0 + cl> gregister m51.500 m51.500.out database m51.coo + cl> display m51.800 1 fi+ + cl> display m51.500.out 2 fi+ +.fi + +4. Use the above transform to transform a list of object pixel coordinates +in the m51.800 image to their pixel coordinates in the m51.500 system. + +.nf + cl> geoxytran m51.800.xy m51.500.xy database m51.coo +.fi + +5. Transform object pixel coordinates in the m51.500 image to their +pixel coordinates in the m51.800 image. Note that to do this the roles +of the reference and input coordinates defined in example 3 must be +reversed and the inverse transform must be computed. + +.nf + cl> fields m51.coo 3,4,1,2 > m51.coo.inv + cl> geomap m51.coo.inv database 1.0 512.0 1.0 512.0 + cl> geoxytran m51.512.xy m51.800.xy database m51.coo.inv +.fi + +6. Compute 3 different transforms, store them in the same database file, +and use them to transform 3 different images. Use the original image names as +the database record names. + +.nf + cl> geomap coo1,coo2,coo3 database 1. 512. 1. 512. \ + >>> transforms=im1,im2,im3 + cl> gregister im1,im2,im3 im1.out,im2.out,im3.out database \ + >>> im1,im2,im3 +.fi + +.ih +BUGS + +The user should be aware that for high order fits the "polynomial" basis +functions become very unstable. Switching to the "legendre" or "chebyshev" +polynomials and/or going to double precision will usually cure the problem. + +.ih +SEE ALSO +imshift, magnify, rotate, imlintran, gregister, geotran, geoxytran +.endhelp diff --git a/pkg/images/immatch/doc/geotran.hlp b/pkg/images/immatch/doc/geotran.hlp new file mode 100644 index 00000000..e3ad15f7 --- /dev/null +++ b/pkg/images/immatch/doc/geotran.hlp @@ -0,0 +1,320 @@ +.help geotran Dec98 images.immatch +.ih +NAME +geotran -- geometrically transform a list of images +.ih +USAGE +geotran input output database transforms +.ih +PARAMETERS +.ls input +List of images to be transformed. +.le +.ls output +List of output images. If the output image name is the same as the input +image name the input image is overwritten. The output image may be a section +of an existing image. The number of output images must equal the number +of input images. +.le +.ls database +The name of the text file containing the coordinate transformation (generally +the database file produced by GEOMAP). +If database is the null string then GEOTRAN will perform a linear +transformation based the values of xin, yin, xout, yout, xshift, yshift, +xmag, ymag, xrotation and yrotation. If all these parameters have their +defaults values the transformation is a null transformation. If the geometric +transformation is linear xin, yin, xout, yout, xshift, yshift, xmag, ymag, +xrotation and yrotation can be used to override the values in the database +file. +.le +.ls transforms +The list of record name(s) in the file \fIdatabase\fR containing the +desired transformations. +This record name is usually the name of the text file input to geomap +listing the reference and input coordinates of the control points. +The number of records must be 1 or equal to the number of input images. +The record names may be listed in a text file 1 record per line. +The transforms parameter is only +requested if database is not equal to the null string. +.le +.ls geometry = "geometric" +The type of geometric transformation. The geometry parameter is +only requested if database is not equal to the null string. The options are: +.ls linear +Perform only the linear part of the geometric transformation. +.le +.ls geometric +Compute both the linear and distortion portions of the geometric correction. +.le +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum x and y reference values of the output image. +If a database file has been defined xmin, xmax, ymin and ymax +efault to the minimum and maximum values set by +GEOMAP and may be less than but may not exceed those values. +.le +.ls xscale = 1.0, yscale = 1.0 +The output picture x and y scales in units of +x and y reference units per output pixel, +e.g arcsec / pixel or Angstroms / pixel if the reference coordinates +are arcsec or Angstroms. If the reference coordinates are in pixels +then xscale and yscale should be 1.0 to preserve the scale of the reference +image. +If xscale and yscale are undefined (INDEF), xscale and yscale default to the +range of the reference coordinates over the range in pixels. +Xscale and yscale override the values of ncols and nlines. +.le +.ls ncols = INDEF, nlines = INDEF +The number of columns and lines in the output image. Ncols and nlines default +to the size of the input image. If xscale or yscale are defined ncols or nlines +are overridden. +.le +.ls xsample = 1.0, ysample = 1.0 +The coordinate surface subsampling factor. The coordinate surfaces are +evaluated at every xsample-th pixel in x and every ysample-th pixel in y. +Transformed coordinates at intermediate pixel values are determined by +bilinear interpolation in the coordinate surfaces. If the coordinate +surface is of high order setting these numbers to some reasonably high +value is strongly recommended. +.le +.ls interpolant = "linear" +The interpolant used for rebinning the image. +The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a user supplied constant value. +.le +.ls reflect +Generate a value by reflecting about the boundary of the image. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0.0 +The value of the constant for boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux. The output pixel values are multiplied by +the Jacobian of the coordinate transformation. +.le +.ls xin = INDEF, yin = INDEF +The x and y coordinates in pixel units in the input image which will map to +xout, yout in the output image. If the database file is undefined these +numbers default to the center of the input image. +.le +.ls xout = INDEF, yout = INDEF +The x and y reference coordinates in the output image which correspond +to xin, yin in the input image. If the database file is undefined, xout and +yout default to the center of the output image reference coordinates. +.le +.ls xshift = INDEF, yshift = INDEF +The shift of the input origin in pixels. If the database file is undefined +then xshift and yshift determine the shift of xin, yin. +.le +.ls xmag = INDEF, ymag = INDEF +The scale factors of the coordinate transformation in units of input pixels +per reference coordinate unit. If database is undefined xmag and ymag +default to 1.0; otherwise xmag and ymag default to the values found +by GEOMAP. If the database file is not null then xmag and ymag override +the values found by GEOMAP. +.le +.ls xrotation = INDEF, yrotation = INDEF +The rotation angles in degrees of the coordinate transformation. +Positive angles are measured counter-clockwise with respect to the x axis. +If database +is undefined then xrotation and yrotation default to 0.0; otherwise +xrotation and yrotation default to the values found by GEOMAP. +If database is not NULL then xrotation and yrotation override the values +found by GEOMAP. +.le +.ls nxblock = 512, nyblock = 512 +If the size of the output image is less than nxblock by nyblock then +the entire image is transformed at once. Otherwise the output image +is computed in blocks of nxblock by nxblock pixels. +.le +.ls verbose = yes +Print messages about the progress of the task ? +.le +.ih +DESCRIPTION + +GEOTRAN corrects an image for geometric distortion using the coordinate +transformation determined by GEOMAP. The transformation is stored as the +coefficients of a polynomial surface in record \fItransforms\fR, +in the text file \fIdatabase\fR. +The coordinate surface is sampled at every \fIxsample\fR and \fIysample\fR +pixel in x and y. +The transformed coordinates at intermediate pixel values are +determined by bilinear interpolation in the coordinate surface. If +\fIxsample\fR and \fIysample\fR = 1, the coordinate +surface is evaluated at every pixel. Use of \fIxsample\fR and \fIysample\fR +are strongly recommended for large images and high order coordinate +surfaces in order to reduce the execution time. + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the range of +reference coordinates represented in the output picture. These numbers +default to the minimum and maximum x and y reference values used by GEOMAP, +and may not exceed those values. +The scale and size of the output picture is determined as follows. + +.nf + ncols = ncols (inimage) + if (xscale == INDEF) + xscale = (xmax - xmin ) / (ncols - 1) + else + ncols = (xmax - xmin) / xscale + 1 + + nlines = nlines (inimage) + if (yscale == INDEF) + yscale = (ymax - ymin ) / (nlines - 1) + else + nlines = (ymax - ymin) / yscale + 1 +.fi + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels. If the +\fIfluxconserve\fR switch is set the output pixel values are multiplied by +the Jacobian of the transformation. +GEOTRAN uses the routines in the 2-D interpolation package. + +The linear portion of the transformation may be altered after the fact +by setting some or all of the parameters \fIxin\fR, \fIyin\fR, \fIxout\fR, +\fIyout\fR, \fIxshift\fR, \fIyshift\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +\fIyrotation\fR. +Xin, yin, xshift, yshift, xout and yout can be used to redefine the shift. +Xmag, and ymag can be used to reset the x and y scale of the transformation. +Xrotation and yrotation can be used to reset the orientation of the +transformation. + +The output image is computed in \fInxblock\fR by \fInyblock\fR pixel sections. +If possible users should set these numbers to values larger than the dimensions +of the output image to minimize the number of disk reads and writes required +to compute the output image. If this is not feasible and the image rotation is +small, users should set nxblock to be greater than the number of columns in +the output image, and nyblock to be as large as machine memory will permit. + +If the CL environment variable \fInomwcs\fR is "no" then the world +coordinate system of the input image will be modified in the output image +to reflect the effects of the \fIlinear\fR portion of the geometric +transformation operation. +Support does not yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that GEOTRAN is capable of +performing. + +.ih +TIMINGS +It requires approximately 70 and 290 cpu seconds to correct a 512 by 512 +square image for geometric distortion using a low order coordinate surface +and bilinear and biquintic interpolation respectively (Vax 11/750 fpa). + +.ih +EXAMPLES + +1. Register two images by transforming the coordinate system of the input +image to the coordinate system of the reference image. The size of the +reference image is 512 by 512. The output image scale will be 1.0 and +its size will be determined by the xmin, xmax, ymin, ymax parameters set +in the task GEOMAP. The file "database" containing the record "m51.coo" +was produced by GEOMAP. + +.nf + cl> geomap m51.coo database 1.0 512.0 1.0 512.0 + cl> geotran m51 m51.tran database m51.coo +.fi + +2. Repeat the above command but set the output image scale to 2.0 reference +images pixels per output image pixel. + +.nf + cl> geomap m51.coo database 1.0 512.0 1.0 512.0 + cl> geotran m51 m51.tran database m51.coo xscale=2.0 yscale=2.0 +.fi + +3. Repeat the previous command using an output scale of +2 reference units per pixel and bicubic spline interpolation with no +flux correction. + +.nf + cl> geomap m51.coo database 1.0 512.0 1.0 512.0 + cl> geotran m51 m51.tran database m51.coo xscale=2. yscale=2. \ + >>> inter=spline3 flux- +.fi + +4. Register a list of 512 by 512 pixel square images using the set of +transforms computed by GEOMAP. The input images, output images, and coordinate +lists / transforms are listed in the files inlist, outlist and reclist +respectively. + +.nf + cl> geomap @reclist database 1. 512. 1. 512. + cl> geotran @inlist @outlist database @reclist +.fi + +5. Mosaic 3 512 square images into a larger 512 by 1536 square images after +applying a shift to each input image. + +.nf + cl> geotran image1 outimage[1:512,1:512] "" ncols=512 nlines=1536 \ + xshift=5.0 yshift=5.0 + cl> geotran image2 outimage[1:512,513:1024] "" xshift=10.0 yshift=10.0 + cl> geotran image3 outimage[1:512,1025:1536] "" xshift=15.0 yshift=15.0 +.fi + +.ih +BUGS +Support does not yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that GEOTRAN is capable of +performing. + +.ih +SEE ALSO +imshift, magnify, rotate, imlintran, geomap, geoxytran, gregister +.endhelp diff --git a/pkg/images/immatch/doc/geoxytran.hlp b/pkg/images/immatch/doc/geoxytran.hlp new file mode 100644 index 00000000..69e8565c --- /dev/null +++ b/pkg/images/immatch/doc/geoxytran.hlp @@ -0,0 +1,408 @@ +.help geoxytran Apr95 images.immatch +.ih +NAME +geoxytran -- geometrically transform a list of coordinates +.ih +USAGE +geoxytran input output database transforms +.ih +PARAMETERS +.ls input +The list of input coordinate files to be transformed. +.le +.ls output +The list of output transformed coordinate files. The number of output files must +be one or equal to the number of input files. +.le +.ls database +The name of the text database file written by the geomap task which +contains the desired spatial transformation. +If database is undefined geoxytran computes +a linear transformation using the current +values of the xref, yref, xout, yout, xshift, yshift, xmag, ymag, xrotation, +and yrotation parameters. +.le +.ls transforms +The database record containing the desired spatial transformation. +The number of records must be one or equal to the number of input coordinate +files. Transforms is usually the name of the coordinate file that the +geomap task used to compute the spatial transformation. +If defined the values of xref, yref, xout, yout, xshift, yshift, xmag, ymag, +xrotation, and yrotation will supersede the computed values in the +database file. +.le +.ls geometry = "geometric" (linear|geometric) +The type of geometric transformation. The geometry parameter is +only requested if database is defined. The options are: +.ls linear +Perform only the linear part of the spatial transformation. +.le +.ls geometric +Compute both the linear and distortion portions of the spatial transformation. +.le +.le +.ls direction = "forward" (forward|backward) +The transformation direction may be "forward" or "backward". The forward +direction directly evaluates the database solution. The backward +direction iteratively determines the coordinate which evaluates to the +specified coordinate. +.le +.ls xref = INDEF, yref = INDEF +The x and y coordinates of the reference origin. +If the database file is undefined xref and +yref default to [0.0,0.0]. Otherwise xref and yref +default to the mean of minimum and maximum x and y values +[(xmin + xmax) / 2.0, (ymin + ymax) / 2.0] computed by geomap. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in input units +per reference unit. If database is undefined xmag and ymag +default to [1.0, 1.0]. Otherwise xmag and ymag default to the values computed +by geomap. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles in degrees measured counter-clockwise with +respect to the x and y axes. If database +is undefined then xrotation and yrotation are interpreted as the +rotation of the coordinates with respect to the x and y axes and +default to [0.0, 0.0]. For example xrotation and yrotation values of +[30.0, 30.0] will rotate a point 30 counter-clockwise with respect +to the x and y axes. Otherwise xrotation and yrotation default to the +values computed by geomap. Geomap computes the x and y rotation angles +of the x and y axes, not the rotation angle of the coordinates. An output +coordinate system rotated 30 degrees counter-clockwise with respect +to the reference coordinate system will produce xrotation and yrotation +values of [330.0,330.0] or equivalently [-30.0,-30.0] in the database file +not [30.0,30.0]. +.le +.ls xout = INDEF, yout = INDEF +The x and y coordinates of the output origin. +If the database file is undefined xout and +yout default to [0.0,0.0]. +If database is defined xout and yout +default to the position that the reference origin [xref,yref] +occupies in the transformed system. +.le +.ls xshift = INDEF, yshift = INDEF +The x and y shift of the reference origin in output units. +If the database file is undefined xshift and yshift default to [0.0,0.0]. +If the database file is defined xshift and yshift default to the +values computed by geomap. If defined xshift and yshift take precedence over +the x and y shifts determined from xref, yref, xout and yout. +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate file containing the x and y coordinates. +.le +.ls calctype = "real" +The precision of the coordinate transformation calculations. The options +are "real" and "double". Note that this only applies to a "forward" +transformation. The "backward" transformation is done iteratively and +is always calculated in double precision to get the best convergence. +.le +.ls xformat = "", yformat = "" +The default output format for the computed x and y coordinates. If +xformat and yformat are undefined geoxytran outputs the coordinates +using the maximum of the precision of the input coordinates +and the value of the \fImin_sigdigits\fR parameter. +.le +.ls min_sigdigits = 7 +The minimum precision of the output x and y coordinates. +.le + +.ih +DESCRIPTION + +GEOXYTRAN applies a coordinate transformation to a list of reference +coordinates in the text file \fIinput\fR and writes the transformed +coordinates to the text file \fIoutput\fR. The input coordinates +are read from, and the output coordinates written to, columns +\fIxcolumn\fR and \fIycolumn\fR in the input and output +files. The format of the output coordinates can be specified using the +\fIxformat\fR and \fIyformat\fR parameters. If the output formats +are unspecified the coordinates are written out with a precision +which is the maximum of the precision of the input coordinates +and the value of the \fImin_sigdigits\fR parameter. All remaining fields in +the input file are copied to the output file without modification. +Blank lines and comment lines are also passed to the output file +unaltered. + +The coordinate transformation either be read from record \fItransforms\fR +in the database file \fIdatabase\fR computed by GEOMAP, or specified +by the user via the \fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, +\fIxrotation\fR, \fIyrotation\fR, \fIxout\fR, \fIyout\fR, \fIxshift\fR, +and \fIyshift\fR parameters. + +The transformation computed by GEOMAP has the following form. + +.nf + xout = f (xref, yref) + yout = g (xref, yref) +.fi + +The functions f and g are either a power series polynomial or a Legendre +or Chebyshev polynomial surface whose order and region of validity were +set by the user when GEOMAP was run. The computed transformation is +arbitrary and does not correspond to any physically meaningful model. +However the first order terms can be given the simple geometrical +interpretation shown below. + +.nf + xout = a + b * xref + c * yref + yout = d + e * xref + f * yref + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = x0 - b * xref0 - c * yref0 = xshift + d = y0 - e * xref0 - f * yref0 = xshift +.fi + +Xref0, yref0, x0, and +y0 are the origins of the reference and output coordinate systems +respectively. xmag and ymag are the x and y scale factors in output units +per reference unit and xrotation and yrotation are the rotation angles measured +counter-clockwise of the x and y axes. + +The linear portion of the GEOMAP transformation may be altered after the fact +by setting some or all of the parameters \fIxref\fR, \fIyref\fR, \fIxout\fR, +\fIyout\fR, \fIxshift\fR, \fIyshift\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +and \fIyrotation\fR. If defined these parameters will replace the corresponding +values in the GEOMAP database file. +Xref, yref, xshift, yshift, xout and yout can be used to redefine the shift +where xshift and yshift take precedence over xref, yref, xout and yout. +Xmag, and ymag can be used to reset the scale of the transformation. +Xrotation and yrotation can be used to redefine the orientation of the +transformation. Note that xrotation and yrotation are interpreted as +the rotation of the coordinate axes not the coordinates. +The default values of these parameters are. + +.nf + xref = (xmin + xmax) / 2.0 + yref = (ymin + ymax) / 2.0 + xout = f (xref,yref) + yout = g (xref,yref) + xshift = xshift (database) = xout - f(xref,yref) + yshift = yshift (database) = yout - g(xref,yref) + xmag = xmag (database) + ymag = ymag (database) + xrotation = xrotation (database) + yrotation = yrotation (database) +.fi + +If the GEOMAP database is undefined then GEOXYTRAN performs a linear +transformation on the input coordinates using the parameters +\fIxref\fR, \fIyref\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +\fIyrotation\fR, \fIxout\fR, \fIyout\fR, \fIxshift\fR, and +\fIyshift\fR as shown below. Note that in this case xrotation and +yrotation are interpreted as the rotation of the coordinates +themselves not the coordinate axes. + +.nf + xout = a + b * xref + c * yref + yout = d + e * xref + f * yref + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xo - b * xref0 - c * yref0 = xshift + d = yo - e * xref0 - f * yref0 = xshift +.fi + + +.ih +Forward vs. Backward Transformations + +The transformation direction is specified by the \fIdirection\fR parameter +which may take the values "forward" or "backward". The forward transformation +is a direct evaluation of the database solution. The backward +transformation is an iterative evaluation to obtain the coordinate which +evaluates to the desired coordinate. + +When the same solution is used with \fBgeotran\fR to transform an image +to another image matching the "reference" image is needed to obtain +coordinates in the transformed image. This is because the transformation +is produced with \fBgeomap\fR to map "reference" coordinates to the +image which is subsequently transformed. Therefore, if you have coordinates +in the image which has been transformed then you should use the "backward" +transformation to get coordinates for the transformed image. But if you +have standard coordinates from the reference image being matched then you +would use the "forward" transformation. If you are not sure then you can +use \fBtvmark\fR to overlay the results to find which direction produces +the desired coordinates. + +Because the backward transformation is performed iteratively it can be +slow. If higher speeds are desired, such as when evaluating a very +large number of coordinates, one might create a transformation solution +that can be evaluated in the forward direction. This is done by +using \fBgeomap\fR with the reference and target coordinates reversed. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +EXAMPLES + +.nf +1. Compute the transformation from the reference system to the output +system and then evaluate the transformation for both the input list and +the list of unknowns. + + cl> type rtran + + 1.0000 1.0000 184.1445 -153.0376 + 512.0000 1.0000 684.0376 184.1445 + 512.0000 512.0000 346.8555 684.0376 + 1.0000 512.0000 -153.0380 346.8555 + + cl> geomap rtran rtran.db 1.0 512.0 1.0 512.0 intera- + + cl> type rtran.db + + # Tue 14:53:36 18-Apr-95 + begin rtran + output rtran.db + xrefmean 256.5 + yrefmean 256.5 + xmean 265.4999 + ymean 265.5 + xshift 183.826 + yshift -154.6757 + xmag 1.180001 + ymag 1.179999 + xrotation 326. + yrotation 326. + surface1 11 + 3. 3. + 2. 2. + 2. 2. + 0. 0. + 1. 1. + 512. 512. + 1. 1. + 512. 512. + 183.826 -154.6757 + 0.9782647 0.6598474 + -0.6598479 0.9782643 + surface2 0 + + cl> geoxytran rtran STDOUT rtran.db rtran + + 184.1444 -153.038 184.1445 -153.0376 + 684.0377 184.1444 684.0376 184.1445 + 346.8554 684.0375 346.8555 684.0376 + -153.038 346.8555 -153.038 346.8555 + + cl> geoxytran unknowns unknowns.tran rtran.db rtran + + +2. Evaluate the backward transformation to take coordinates from the +output system to the reference system. In this example we use the +output of the first example to illustrate getting back the coordinates +used in the original geomap input. + + cl> geoxytran rtran STDOUT rtran.db rtran dir=forward |\ + >>> geoxytran STDIN STDOUT rtran.db rtran dir=backward + 0.999798 0.9997257 184.1445 -153.0376 + 512. 0.9999674 684.0376 184.1445 + 512. 512. 346.8555 684.0376 + 0.999918 512.0001 -153.0380 346.8555 + + +3. Evaluate the transform computed in example 1 for the same list of +unknowns but modify the transformation slightly by setting xmag +and ymag to 1.18 and 1.18 exactly. + + cl> geoxytran unknowns unknowns.tran rtran.db rtran xmag=1.18 \ + ymag=1.18 + + +4. Evaluate the same transformation for the same unknowns as before +using the linear transformation parameters not the transform computed +by geomap. Note that the angle is the negative of the one defined +in the database file. + + cl> geoxytran unknowns unknowns.tran "" xmag=1.18 ymag=1.18 \ + xrot=34 yrot=34 xshift=183.826 yshift=-154.6757 +.fi + +.ih +BUGS + +.ih +SEE ALSO +geomap, lists.lintran, geotran, gregister +.endhelp diff --git a/pkg/images/immatch/doc/gregister.hlp b/pkg/images/immatch/doc/gregister.hlp new file mode 100644 index 00000000..73dff3d4 --- /dev/null +++ b/pkg/images/immatch/doc/gregister.hlp @@ -0,0 +1,265 @@ +.help gregister Dec98 images.immatch +.ih +NAME +gregister -- transform a list of images from one coordinate system to another +.ih +USAGE +gregister input output database transforms +.ih +PARAMETERS +.ls input +List of images to be transformed. +.le +.ls output +List of output images. +.le +.ls database +The name of the text file database produced by GEOMAP containing the coordinate +transformation(s). +.le +.ls transforms +The list of the database record(s) containing the transformations. +The number of transforms must be 1 or the same as the number of input +images. Transforms is usually the name of the +text file input to GEOMAP which lists the reference and input +coordinates of the control points. +.le +.ls geometry = "geometric" +The type of geometry to be applied: The choices are: +.ls linear +The linear part, shifts, scales and rotations are computed. +.le +.ls geometric +The full transformation is computed. +.le +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum x and y reference values of the output image. +Xmin, xmax, ymin and ymax default to minimum and maximum values set in GEOMAP, +and may not extend beyond the bounds of those parameters. +.le +.ls xscale = 1.0, yscale = 1.0 +The output x and y scales in units of reference x and y +units per pixel, e.g "/ pixel or Angstroms / pixel if the reference +coordinates +are arc-seconds or Angstroms. If the reference coordinates are in pixels +then xscale and yscale should be 1.0 to preserve the scale of the reference +image. The default is set for pixel coordinates. +If xscale and yscale are undefined (INDEF), xscale and yscale default to the +range of the reference coordinates over the range in pixels. +Xscale and yscale override the values of ncols and nlines. +.le +.ls ncols = INDEF, nlines = INDEF +The number of columns and lines in the output image. Ncols and nlines default +to the size of the input image. If xscale or yscale are defined ncols or nlines +are overridden. +.le +.ls xsample = 1.0, ysample = 1.0 +The coordinate surface subsampling factor. The coordinate surfaces are +evaluated at every xsample-th pixel in x and every ysample-th pixel in y. +Transformed coordinates at intermediate pixel values are determined by +bilinear interpolation in the coordinate surfaces. +.le +.ls interpolant = "linear" +The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The boundary extension choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a constant value. +.le +.ls reflect +Generate value by reflecting about the boundary. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0. +The value of the constant for boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux. The output pixel values are multiplied by +the Jacobian of the coordinate transformation. +.le +.ls nxblock = 512, nyblock = 512 +If the dimensions of the output image are less than nxblock and nyblock +then the entire image is transformed at once. Otherwise blocks of size +nxblock by nyblock are transformed one at a time. +.le +.ls verbose = yes +Print messages about the progress of the task ? +.le +.ih +DESCRIPTION + +GREGISTER corrects an image for geometric distortion using the coordinate +transformation computed by GEOMAP. The transformation is stored as the +coefficients of a polynomial surface in record \fItransforms\fR, +in the text file \fIdatabase\fR. +The coordinate surface is sampled at every \fIxsample\fR and \fIysample\fR +pixel in x and y. +The transformed coordinates at intermediate pixel values are +determined by bilinear interpolation in the coordinate surface. If +\fIxsample\fR and \fIysample\fR = 1, the coordinate +surface is evaluated at every pixel. Use of \fIxsample\fR and \fIysample\fR +are strongly recommended for large images and high order coordinate +surfaces in order to reduce the execution time. + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the range of +reference coordinates represented in the output picture. These numbers +default to the minimum and maximum x and y reference values used by GEOMAP, +and may not exceed these values. +The scale and size of the output picture is determined as follows. + +.nf + ncols = ncols(input) + if (xscale == INDEF) + xscale = (xmax - xmin ) / (ncols - 1) + else + ncols = (xmax - xmin) / xscale + 1 + + nlines = nlines(input) + if (yscale == INDEF) + yscale = (ymax - ymin ) / (nlines - 1) + else + nlines = (ymax - ymin) / yscale + 1 +.fi + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels. If the +\fIfluxconserve\fR switch is set the output pixel values are multiplied by +the Jacobian of the transformation. GREGISTER uses the routines in the +2-D interpolation package. + +The output image is computed in \fInxblock\fR by \fInyblock\fR pixel sections. +If possible users should set these numbers to values larger than the dimensions +of the output image, in order to minimize the number of disk reads and writes +required to compute the output image. If this is not feasible and the image +rotation is small users should set nxblock to be greater than the number of +columns in the output image, and nyblock to be as large as machine memory +will permit. + +If the environment variable \fInomwcs\fR is "no" then the world coordinate +system of the input image is modified in the output image to reflect the +effects of the \fIlinear\fR portion of the registration operation. +Support does not yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that GREGISTER is capable +of performing. + +.ih +TIMINGS +It requires approximately 70 and 290 cpu seconds to correct a 512 by 512 +square image for geometric distortion using a low order coordinate surface +and bilinear and biquintic interpolation respectively (Vax 11/750 far). + +.ih +EXAMPLES +.ls 4 1. +Transform an image to the reference coordinate system of a 512 by 512 pixel +square image. The output image will have the same scale and size as the +reference image if the reference coordinates are in pixels. + +.nf +cl> geomap coords database 1.0 512.0 1.0 512.0 +cl> gregister input output database coords +.fi +.le +.ls 4 2. +Repeat the previous example but rescale the output image. The scale of the +output image will be 2.5 reference units per pixel and its size will be +determined by the xmin, xmax, ymin, ymax parameters (1.0, 512.0, 1.0, 512.0). + +.nf +cl> geomap coords database 1.0 512.0 1.0 512.0 +cl> gregister input output database coords xscale=2.5 yscale=2.5 +.fi +.le +.ls 4 3. +Correct an image for 3rd order geometric distortion using an output scale of 2 +reference units per pixel unit and bicubic spline interpolation with no flux +correction. + +.nf +cl> geomap coords database 1.0 512.0 1.0 512.0 xxorder=4 xyorder=4 \ +xxterms=yes yxorder=4 yyorder=4 yxterms=yes +cl> gregister input output database coords xscale=2. yscale=2. \ +>>> inter=spline3 flux- +.fi +.le +.ls 4 4. +Transform three images using 3 different transformation records stored +in the database file. + +.nf +cl> geomap coord1,coord2,coord3 database 1. 512. 1. 512. +cl> gregister im1,im2,im3 imout1,imout2,imout3 database \ +>>> coord1,coord2,coords3 +.fi +.le +.ls 4 5. +Repeat the above example using the textfiles inlist, outlist, reclist which +contain the list of input images, list of output images and list of coordinate +files respectively. + +.nf +cl> geomap @reclist database 1. 512. 1. 512. +cl> gregister @inlist @outlist database @reclist +.fi +.le + +.ih +BUGS +Support does yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that GREGISTER is capable +of performing. + +.ih +SEE ALSO +imshift, magnify, rotate, imlintran, geomap, geotran, geoxytran +.endhelp diff --git a/pkg/images/immatch/doc/imalign.hlp b/pkg/images/immatch/doc/imalign.hlp new file mode 100644 index 00000000..c63be5bc --- /dev/null +++ b/pkg/images/immatch/doc/imalign.hlp @@ -0,0 +1,316 @@ +.help imalign Feb90 images.immatch +.ih +NAME +imalign -- register a list of images by computing relative object shifts +.ih +USAGE +imalign input reference coords output +.ih +PARAMETERS +.ls input +The input images to be shifted and trimmed. The input image list should +contain the reference image so that its borders are +used in the computation of the overlap region. +.le +.ls reference +The reference image to which the input images will be aligned. +.le +.ls coords +A text file containing the reference image coordinates of the registration +objects to be centered in each image, one object per line with the x and y +coordinates in columns one and two respectively. +.le +.ls output +The output images. +.le +.ls shifts = "" +A text file containing the initial estimate for each image of the +shift in each axis relative to the reference image. These +estimates are used to modify the coordinates of the registration +objects prior to centering. The format of the file is one image per +line with the x and y shifts in columns one and two respectively. +The sense of the shifts is such that: \fIXshift=Xref-Xin\fR and +\fBYshift=Yref-Yin\fR. If \fIshifts\fR is null, a coarse centering +pass will be made to attempt to determine the initial shifts. +.le +.ls boxsize = 7 +The size in pixels of the box to use for the final centering, during +which all the sources in \fIcoords\fR are recentered in each image +using the initial estimate of the relative shift for each image. +Care should be taken to choose an appropriate value for this parameter, +since it is highly data dependent. +.le +.ls bigbox = 11 +The size in pixels of the box to use for coarse centering. The coarse +pass through the centering algorithm is made with the box centered at +the nominal position of the first source in the coordinate list. +Coarse centering is performed only if the shifts file is undefined. +Care should be taken to choose an appropriate value for this parameter, +since it is highly data dependent. Large values should be suspect until +the final results are checked to see that the centering did not converge +on the wrong coordinates, although the usual result for an inappropriate +\fIbigbox\fR size is that the algorithm fails to converge and the task +aborts. +.le +.ls negative = no +Are the features negative ? +.le +.ls background = INDEF +The absolute reference level for the marginal centroid calculation. +If background is INDEF, this is set to the mean value (between the +thresholds) of the individual sources. +.le +.ls lower = INDEF +The lower threshold for the data. Individual pixels less than this +value will be given zero weight in the centroids. +.le +.ls upper = INDEF +The upper threshold for the data. Individual pixels greater than this +value will be given zero weight in the centroids. +.le +.ls niterate = 3 +The maximum number of centering iterations to perform. The centering +will halt when this limit is reached or when the desired Itolerance +is achieved. +.le +.ls tolerance = 0 +The tolerance for convergence of the centering algorithm. This is the +integral shift of the centering box from one iteration to the next. +.le +.ls maxshift = INDEFR +The maximum permitted difference between the predicted shift and the +the computed shift for each object. Objects with shifts greater than +maxshift are ignored. If maxshift is undefined no shift checking is done. +.le +.ls shiftimages = yes +If shiftimages is yes, the IMSHIFT task will be used to align the +images. If shiftimages is no, the images will not be aligned, but +the coordinates will still be centered. +.le +.ls interp_type = "spline3" +The interpolation function used by the IMSHIFT task. +.le +.ls boundary_type = "constant" +The boundary extension type used by the IMSHIFT task. +.le +.ls constant = 0. +The constant used by the IMSHIFT task if \fIboundary_type\fR is "constant". +.le +.ls trimimages = yes +If trimimages is yes, the output images will be trimmed to +include only the region over which they all overlap. The +trim section that is actually used may differ slightly from that +reported by IMCENTROID, due to a correction applied to compensate for +the boundary extension "contamination" near the edges of the images. +.le +.ls verbose = yes +Print the centers, shifts, and trim section? +.le +.ih +DESCRIPTION +IMALIGN measures the X and Y axis shifts between a list of input images +\fIinput\fR and a reference image \fIreference\fR, registers the +input images to the reference image using the computed shifts, +and trims the input images to a common overlap region. +The task is meant to address the class of two dimensional image +registration problems in which the images have the same pixel scale, +are shifted relative to each other by simple x and y translations, and contain +enough high signal / noise, pointlike sources in common to compute good +average positions. The basic operation of the task is to find centers +for the list of registration objects or features in the coordinate +frame of each image and then to subtract the corresponding centers +found in the reference image. The shifts of the registration objects +are averaged for each image. + +IMALIGN is a simple script front end for IMCENTROID, which computes the +shifts, IMSHIFT, which shifts the images, and +IMCOPY, which performs the trimming. + +A list of the X and Y coordinates of the registration objects should be +provided via the \fIcoords\fR parameter. The registration objects do not +all have to be common to each frame; only that subset of the +objects that is contained within the bounds of a given image will be +centered. Only the objects that are common to both the given image and +the reference will be used to calculate the shifts. The coordinates +must be measured in the frame of the reference image. If coarse +centering is to be done, which is to say, if no \fIshifts\fR file is +provided, then the first registration source should be separated from +other sources by at least the maximum expected relative shift. + +An initial estimate of the shifts between each of the input images and +the reference image is required for the centering algorithm (a marginal +centroid) to work. This estimate can be explicitly supplied in the file +\fIshifts\fR (\fIXshift=Xref-Xin\fR and \fIYshift=Yref-Yin\fR) or can +be generated from the images by measuring the relative shift of the +first source listed in the coords file for each image. This coarse +centering pass requires that the first source be detached from other +sources and from the border of each image, by a distance that is at +least the maximum shift between the reference and input image. This +source should be pointlike and have a high signal to noise ratio. The +value of the \fIbigbox\fR parameter should be chosen to include the +location of the source in each of the images to be aligned while +excluding other sources. Large values of \fIbigbox\fR should be held +suspect until the final convergence of the centering algorithm is +verified, although given a small value for the \fItolerance\fR, the +quality of the final centers is independent of the estimate for the +initial shifts. Better convergence may also be obtained by increasing +the \fIniterate\fR parameter, although the default value of three +should work for most cases. \fINiterate\fR should be kept small to +avoid runaway. + +The \fIboxsize\fR parameter controls the size of the centering box for +the fine centering passes and should be chosen so as to exclude sky +background and other sources while including the wings of the point +spread function. The sense of the shifts that are calculated is +consistent with the file supplied to the \fIshifts\fR parameter and +with that used with the IMSHIFT task. + +If \fIshiftimages\fR is yes the images will actually be shifted using +the IMSHIFT task. Note that if \fIinterp_type\fR is "nearest" the +effect on the images is the same as if the shifts were rounded to +integral values. In this case, the pixels will be shifted without +interpolation. This can be used for data in which it is more important +to preserve the pixel values than it is to achieve perfect +registration. + +If \fItrimimages\fR is yes, the output images will be trimmed to +include only the region over which they all overlap. The trim section +that is actually used may differ slightly from that reported by +IMCENTROID. A one or two pixel correction may be applied to each edge +to compensate for the boundary extension "contamination" due to +multi-pixel (e.g., \fIinterp_type\fR = poly5) interpolation near the +edges of the images. + +IMALIGN may be used with a set of \fIimages\fR which vary in size. +This can result in vignetting of the calculated overlap region because +of the nature of the IMSHIFT task to preserve the size of an input +image. To visualize this, imagine a large reference image and a single +small image to be aligned to it, both containing the same registration +object which is at the center of each image. IMALIGN will cause the +small image to be shifted such that the object is positioned at the same +pixel location as in the reference. In performing the shift, a large +fraction of the area of the small image may be shifted outside of its +own borders, whereas the physical overlap of the large and small images +includes ALL of the pixels of the small image. In the case of such +vignetting, IMALIGN will print a warning message and refuse to proceed +with the trimming although the vignetting will occur whether or not the +images are trimmed. Note that the vignetting will not occur if the +small image is used as the \fIreference\fR. + +The vignetting message may also be printed if the \fIimages\fR are all +the same size but the \fIreference\fR is not included in the list. +This will occur if the sense of the measured shifts in a coordinate are +all positive or all negative since in this case the border of the +\fIreference\fR would have provided one of the limits to the trim +section. The reality of this vignetting depends on your point of view. + +Trimming will also not be performed if the entire overlap region vanishes. + +Note that many of these difficulties are due to the intrinsically fuzzy +nature of the process of image registration. This all leads to a few +"rules of thumb": + +.nf + o Include the reference image in the input image list + + o Use the smallest image as the reference image + + o Choose the reference image such that the input images are + scattered to either side in the shifts in each axis + + o Align images that are the same size, OR + + o Pad dissimilar sized images with blanks to + the largest size and disable trimming +.fi +.ih +CENTERING ALGORITHM +The algorithm is a "marginal" centroid in which the fit for each axis +is performed separately upon a vector created by collapsing the +centering box perpendicular to that axis. The centroid is calculated +with respect to the level specified by \fIbackground\fR. If +\fIbackground\fR is INDEF, the reference level for each source in each +image is the local mean for those pixels that lie between the +\fIlower\fR and \fIupper\fR thresholds. The thresholds are set to the +local data minimum or maximum if \fIlower\fR or \fIupper\fR, +respectively, are INDEF. If \fInegative\fR is yes, than the marginal +vector will be inverted before being passed to the centroid algorithm. + +The maximum number of centering iterations and the tolerance for +convergence are controlled by \fIniterate\fR and \fItolerance\fR. Note +that the tolerance is an integer value that represents the maximum +movement of the centering box between two successive iterations. The +default value of 0 requires that the centroid lie within the center +pixel of the centering box which is \fIboxsize\fR in extent (note that +\fIboxsize\fR must be an odd number). This should normally be the case +for bright, circularly symmetric point sources in images with a flat +sky background. If the registration sources are not circular symmetric +try increasing the tolerance gingerly. A sky level that varies across +the image should be removed before processing. The centering and +calculation of the shifts may be performed with \fIshiftimages\fR = no +(or directly with IMCENTROID) and the calculated shifts applied to the +images directly with IMSHIFT. + +.ih +EXAMPLES +1. Align three images to the first using the list of registration star +coordinates in the file "x1.coords". + +.nf + cl> imalign x1,x2,x3 x1 x1.coords x1.out,x2.out,x3.out +.fi + +2. Align a list of images contained in the file "imlist", overwriting the +original images with the shifted and trimmed images: + +.nf + cl> imalign @imlist x1 x1.coords @imlist +.fi + +3. Align the images leaving the output images the same size as the input +images: + +.nf + cl> imalign @imlist x1 x1.coords @outlist trimimages- +.fi + +4. Perform the centering but not the shifts: + +.nf + cl> imalign @imlist x1 x1.coords shiftimages- +.fi + +5. Perform the centering, but don't calculate the shifts at all, +and don't shift the image. + +.nf + pr> imalign @imlist "" x1.coords shiftimages- +.fi + +.ih +BUGS +The images being shifted must be in the current directory. + +The coarse centering portion of the algorithm can be fooled if the +first source on the list is not well separated from other sources, or +if the first source has a low signal to noise ratio, or if there is a +complicated shape to the background. + +The task can produce output images that do not contain the entire +overlap region. This can only occur if the images are of varying sizes. +This behavior is caused by the action of the IMSHIFT task to preserve the +size of an input image, thus implicitly "trimming" the image. A work +around is to use IMCOPY to place the images into subsections of blank +images that are the size (in each dimension) of the largest image(s) +and use IMALIGN with \fItrimimages\fR set to no. The borders of the output +images can be trimmed manually. This is discussed above in more detail. + +If \fIimages\fR does not contain the \fIreference\fR and \fItrimimages\fR +is set to yes then the set of shifted and trimmed images may no longer +be aligned to the reference. This occurs because any place holder +pixels at the bottom and left edges of the images will be trimmed off. +This is also discussed above. +.ih +SEE ALSO +imcentroid, center, imshift, geomap, geotran +.endhelp diff --git a/pkg/images/immatch/doc/imcentroid.hlp b/pkg/images/immatch/doc/imcentroid.hlp new file mode 100644 index 00000000..c284d9be --- /dev/null +++ b/pkg/images/immatch/doc/imcentroid.hlp @@ -0,0 +1,257 @@ +.help imcentroid Jan97 images.immatch +.ih +NAME +imcentroid -- center sources in images, optionally find shifts + +.ih +USAGE +imcentroid input reference coords + +.ih +PARAMETERS + +.ls input +The list of images within which sources are to be centered. If a +\fIreference\fR image is specified, imcentroid will calculate the mean +X and Y shifts between the centered sources within each image and those +same sources within the reference image. The input image list +should normally include the reference image so that its borders are +used in the calculation of the overlap region. +.le +.ls reference = "" +The reference image to which the input images will be aligned. If +a reference image is specified the mean X and Y shifts between each of +the input images and the reference image will be calculated, otherwise +only the centers for the individual sources will be reported. +.le +.ls coords +A text file containing the coordinates of the registration objects to +be centered in each image, one object per line with the x and y +coordinates in columns one and two respectively. These coordinates +should be measured in the frame of the reference image. +.le +.ls shifts = "" +A text file containing the initial estimate for each image of the +shift in each axis relative to the reference image. These +estimates are used to modify the coordinates of the registration +objects prior to centering. The format of the file is one image per +line with the fractional x and y shifts in columns one and two +respectively. The sense of the shifts is such that: +Xshift =Xref - Xin and shift= Yref - Yin. If shifts is undefined, +a coarse centering pass will be made to attempt to determine +the initial shifts. +.le +.ls boxsize = 7 +The size in pixels of the box to use for the final centering, during +which all the sources in the coords file are recentered in each image +using the initial estimate of the relative shift for each image. +Care should be taken to choose an appropriate value for this parameter, +since it is highly data dependent. +.le +.ls bigbox = 11 +The size in pixels of the box to use for coarse centering. The coarse +pass through the centering algorithm is made with the box centered at +the nominal position of the first source in the coordinate list. +Coarse centering is performed only if the shifts file is undefined. +Care should be taken to choose an appropriate value for this parameter, +since it is highly data dependent. Large value should be suspect until +the final results are checked to see that the centering did not converge +on the wrong coordinates, although the usual result for an inappropriate +bigbox size is that the algorithm fails to converge and the task +aborts. +.le +.ls negative = no +Are the features negative ? +.le +.ls background = INDEF +The absolute reference level for the marginal centroid calculation. +If background is INDEF, this is set to the mean value (between the +thresholds) of the individual sources. +.le +.ls lower = INDEF +The lower threshold for the data. Individual pixels less than this +value will be given zero weight in the centroids. +.le +.ls upper = INDEF +The upper threshold for the data. Individual pixels greater than this +value will be given zero weight in the centroids. +.le +.ls niterate = 3 +The maximum number of centering iterations to perform. The centering +will halt when this limit is reached or when the desired tolerance +is achieved. +.le +.ls tolerance = 0 +The tolerance for convergence of the centering algorithm. This is the +integral shift of the centering box from one iteration to the next. +.le +.ls maxshift = INDEFR +The maximum permitted difference between the predicted shift and the +the computed shift for each object. Objects with shifts greater than +maxshift are ignored. If maxshift is undefined no shift checking is done. +.le +.ls verbose = yes +Print the centers for the individual objects ? If verbose is no +only the shifts relative to the reference coordinates will be reported. +If no reference image is supplied, verbose is automatically set to yes. +.le + +.ih +DESCRIPTION + +IMCENTROID measures the X and Y coordinates of a list of sources in a +list of images and finds the mean X and Y shifts between the input +images \fIinput\fR and a \fIreference\fR image, where the shifts are +defined as the shifts that should be added to the input image coordinates to +convert them into the reference coordinates. The task is meant to +address the class of two dimensional image registration problems in +which the images have the same pixel scale, are shifted relative to +each other by simple translations in each axis, and contain enough high +signal-to-noise, pointlike sources in common to form good average +positions. The basic operation of the task is to find centers for the +list of registration objects in the coordinate frame of each image and +then to subtract the corresponding centers found in the reference +image. The shifts of the objects are averaged for each image. + +A list of the X and Y coordinates of the registration objects should be +provided in the coordinates file \fIcoords\fR. The registration objects do not +all have to be common to each frame, rather only that subset of the +objects that is contained within the bounds of a given image will be +centered. Only the objects that are common to both the given image and +the reference will be used to calculate the shifts. The coordinates +should be measured in the frame of the reference image\fIreference\fR. +If coarse centering is to be done, which is to say, if no \fIshifts\fR file is +provided, then the first registration source should be separated from +other sources by at least the maximum expected relative shift. + +An initial estimate of the shifts between each of the input images +\fIinput\fR and the reference image \fIreference\fR is required for the +centering algorithm (a marginal centroid) to work. This estimate can be +explicitly supplied in the text file \fIshifts\fR where Xshift = Xref -Xin +and Yshift = Yref -Y in, or can be generated from the images by measuring +the relative shift of the first source listed in the coordinates file +\fIcoords\fR for each input image. This coarse +centering pass requires that the first source be detached from other +sources and from the border of each image by a distance that is at +least the maximum shift between the reference and input image. This +source should be pointlike and have a high signal to noise ratio. The +value of the \fIbigbox\fR parameter should be chosen to include the +location of the source in each of the images to be aligned while +excluding other sources. Large values of \fIbigbox\fR should be held +suspect until the final convergence of the centering algorithm is +verified, although given a small value for the \fItolerance\fR, the +quality of the final centers is independent of the estimate for the +initial shifts. Better convergence may also be obtained by increasing +the \fIniterate\fR parameter, although the default value of three +should work for most cases. \fINiterate\fR should be kept small to +avoid runaway. + +The \fIboxsize\fR parameter controls the size of the centering box for +the fine centering pass and should be chosen so as to exclude sky +background and other sources while including the wings of the point +spread function. The sense of the shifts that are calculated is +consistent with the file supplied to the \fIshifts\fR parameter and +with that used with the IMSHIFT task. + +IMCENTROID may be used with a set of input images which vary in size. +This can result in vignetting of the calculated overlap region because +of the nature of tasks such as IMSHIFT to preserve the size of an input +image. To visualize this, imagine a large reference image and a single +small image to be aligned to it, both containing the same registration +object which is at the center of each image. IMCENTROID will cause the +coordinate system of the small image to be shifted such that the object +will be positioned at the same pixel location as in the reference. If +the shift is performed, a large fraction of the area of the small image +may be shifted outside of its own borders, whereas the physical overlap +of the large and small images includes ALL of the pixels of the small +image. In the case of such vignetting, IMCENTROID will print a warning +message and both the vignetted and unvignetted trim sections. Note +that the vignetting will not occur if the small image is used as the +reference image. + +The vignetting message may also be printed if the input images are all +the same size but the reference image is not included in the list. +This will occur if the sense of the measured shifts in a coordinate are +all positive or all negative since in this case the border of the +reference image would have provided one of the limits to the trim +section. The reality of this vignetting depends on your point of view. + +Note that many of these difficulties are due to the intrinsically fuzzy +nature of the process of image registration. This all leads to a few +guidelines: + +.nf + o Include the reference image in the input image list + + o Use the smallest image as the reference image + + o Choose the reference image such that the input images + are scattered to either side in the shifts in each axis + + o Align images that are the same size, OR + + o Pad dissimilar sized images with blanks to the largest size +.fi + +.ih +CENTERING ALGORITHM + +The algorithm is a "marginal" centroid in which the fit for each axis +is performed separately upon a vector created by collapsing the +centering box perpendicular to that axis. The centroid is calculated +with respect to the level specified by \fIbackground\fR. If +\fIbackground\fR is INDEF, the reference level for each source in each +image is the local mean for those pixels that lie between the +\fIlower\fR and \fIupper\fR thresholds. The thresholds are set to the +local data minimum or maximum if \fIlower\fR or \fIupper\fR, +respectively, are INDEF. If \fInegative\fR is yes, than the marginal +vector will be inverted before being passed to the centroid algorithm. + +The maximum number of centering iterations and the tolerance for +convergence are controlled by \fIniterate\fR and \fItolerance\fR. Note +that the tolerance is an integer value that represents the maximum +movement of the centering box between two successive iterations. The +default value of 0 requires that the centroid lie within the center +pixel of the centering box which is \fIboxsize\fR in extent (note that +\fIboxsize\fR must be an odd number). This should normally be the case +for bright, circularly symmetric point sources in images with a flat +sky background. If the registration sources are not circular symmetric +try increasing the tolerance gingerly. If the sky background is not +flat, but varies across the image, it can be removed before processing. + +.ih +EXAMPLES + +1. Calculate the shifts between three images using the first image +as a reference image and the list of registration star coordinates in +the file "x1.coords". + +.nf + cl> imcentroid x1,x2,x3 x1 x1.coords +.fi + +2. Calculate the shifts between a list of images contained in the file +"imlist": + +.nf + pr> imcentroid @imlist x1 x1.coords +.fi + +3. Perform the centering, but don't calculate the shifts, i.e., don't +supply a reference image. Note that the \fIinput\fR list of shifts, +or a coarse centering pass are still needed: + +.nf + pr> imcentroid @imlist "" x1.coords +.fi + +.ih +BUGS +The coarse centering portion of the algorithm can be fooled if the +first source on the list is not well separated from other sources, or +if the first source has a low signal to noise ratio, or if there is a +complicated shape to the background. +.ih +SEE ALSO +imalign, imshift, xregister, geomap, geotran +.endhelp diff --git a/pkg/images/immatch/doc/imcombine.hlp b/pkg/images/immatch/doc/imcombine.hlp new file mode 100644 index 00000000..720fe785 --- /dev/null +++ b/pkg/images/immatch/doc/imcombine.hlp @@ -0,0 +1,1471 @@ +.help imcombine Aug01 images.immatch +.ih +NAME +imcombine -- Combine images using various algorithms +.ih +USAGE +imcombine input output +.ih +PARAMETERS +.ls input +List of input images to combine. If the \fIproject\fR parameter is "no" +then all input images must have the same dimensionality though they may +be of different sizes. Otherwise each input image is handled separately +and they may have different dimensionalities. +.le + + +When the \fIproject\fR parameter is "no" all the input images are combined +into a single output file. In this case the following parameters specify +only a single file name. Otherwise each input image is combined by +projecting (combining across) the highest dimension to produce a lower +dimensional image. For this type of combining there is one output for each +input and so the following parameters specify matching lists. + +.ls output +Output combined image(s). If there are fewer than 100 input images the +names of the input images are recorded in header keywords IMCMBnnn. +.le +.ls headers = "" (optional) +Optional output multiextension FITS file(s). The extensions are dataless +headers from each input image. +.le +.ls bpmasks = "" (optional) +Optional output bad pixel mask(s) with good values of 0 and bad values of +1. Output pixels are marked as bad when no input pixels contributed to the +output pixel. The file name is also added to the output image header under +the keyword BPM. +.le +.ls rejmask = "" (optional) +Optional output mask file(s) identifying rejected or excluded pixels. The +pixel mask is the size of the output image but there is one extra dimension +with length equal to the number of input images. Each element of the +highest dimension is a mask corresponding to an input image with values of +1 for rejected or excluded pixels and values of 0 for pixels which were +used. The order of the masks is the order of the input images and image +header keywords, indexed by the pixel coordinate of the highest dimension +identify the input images. Note that the pixel positions are in the output +pixel coordinate system. +.le +.ls nrejmasks = "" (optional) +Optional output pixel mask(s) giving the number of input pixels rejected or +excluded from the input images. +.le +.ls expmasks = "" (optional) +Optional output exposure mask(s) giving the sum of the exposure values of +the input images with non-zero weights that contributed to that pixel. +Since masks are integer, the exposure values may be scaled to preserve +dynamic range and fractional significance. The scaling values are given in +the header under the keywords MASKSCAL and MASKZERO. Exposure values are +computed from the mask values by scale * value + zero where scale is the +value of the MASKSCAL keyword and zero is the value of the MASKZERO +keyword. +.le +.ls sigma = "" (optional) +Optional output sigma image(s). The sigma is the standard deviation, +corrected for a finite population, of the input pixel values (excluding +rejected pixels) about the output combined pixel values. +.le + +.ls imcmb = "$I" (optional) +A keyword in the input images that is copied +to one of the IMCMBnnn keywords in the output image. A null string +does not set the IMCMBnnn keywords nor deletes any existing keywords. +Any other value will delete existing keywords before creating new ones. +The special value "$I" specifies the basename of the input image name. +If a keyword is specified that does not exist in the input image(s) then +no ICMB keyword will be produced; it is not a error for the keyword to +not exist. +.le +.ls logfile = "STDOUT" (optional) +Optional output log file. If no file is specified then no log information is +produced. The special filename "STDOUT" prints log information to the +terminal. +.le + +.ls combine = "average" (average|median|lmedian|sum|quadrature|nmodel) +Type of combining operation performed on the final set of pixels (after +offsetting, masking, thresholding, and rejection). The choices are: + +.nf + average - weighted average + median - median + lmedian - median except use the lower value if only two + sum - (weighted) sum + quadrature - weighted quadrature average + nmodel - weighted quadrature average of noise model values +.fi + +The details of each choice is given in the DESCRIPTION. +Note that if weights are used then the weighted "sum" is the same as +the weighted "average" since the weights are normalized to unit total weight. +The "lmedian" option is intended for minimizing the effects of cosmic rays +when there are more than two images but some pixels may only have two +contributing images. The "quadrature" and "nmodel" options are used +for error propagation either with input sigma images (quadrature) or where the +pixel sigmas may be computed by the noise model used by this task (nmodel). +.le +.ls reject = "none" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) +Type of rejection operation performed on the pixels remaining after offsetting, +masking and thresholding. The algorithms are described in the +DESCRIPTION section. The rejection choices are: + +.nf + none - No rejection + minmax - Reject the nlow and nhigh pixels + ccdclip - Reject pixels using CCD noise parameters + crreject - Reject only positive pixels using CCD noise parameters + sigclip - Reject pixels using a sigma clipping algorithm + avsigclip - Reject pixels using an averaged sigma clipping algorithm + pclip - Reject pixels using sigma based on percentiles +.fi + +.le +.ls project = no +Project (combine) across the highest dimension of the input images? If +"no" then all the input images are combined to a single output image. If +"yes" then the highest dimension elements of each input image are combined to +an output image and optional pixel list and sigma images. Each element of +the highest dimension may have a separate offset. +.le +.ls outtype = "real" (none|short|ushort|integer|long|real|double) +Output image pixel datatype. The pixel datatypes are "double", "real", +"long", "integer", unsigned short "ushort", and "short" with highest +precedence first. If "none" is specified then the highest precedence +datatype of the input images is used. When there is a mixture of +short and unsigned short images the highest precedence become integer. +The datatypes may be abbreviated to a single character. +.le +.ls outlimits = "" +Output region limits specified as pairs of whitespace separated values. +The first two numbers are the limits along the first output image dimension, +the next two numbers are the limits along the second dimension, and so on. +If the higher dimension limits are not specified they default to the full +range. Therefore, if no limits are specified then the full output is +created. Note that the output size is computed from all the input images +including offsets if specified and the coordinates are relative to that +size. +.le +.ls offsets = "none" (none|wcs|world|physical|grid|) +Integer offsets to add to each image axes. The options are: +.ls "none" +No offsets are applied. +.le +.ls "wcs" or "world" +The world coordinate system (wcs) in the image is used to derive the +offsets. The nearest integer offset that matches the world coordinate +at the center of the first input image is used. +.le +.ls "physical" +The physical coordinate system defined by the IRAF LTM/LTV keywords +define the offsets. +.le +.ls "grid" +A uniform grid of offsets is specified by a string of the form + +.nf + grid [n1] [s1] [n2] [s2] ... +.fi + +where ni is the number of images in dimension i and si is the step +in dimension i. For example "grid 5 100 5 100" specifies a 5x5 +grid with origins offset by 100 pixels. +.le +.ls +The offsets are given in the specified file. The file consists +of one line per image with the offsets in each dimension forming the +columns. +.le +.le +.ls masktype = "none" +Type of pixel masking to use. The choices are + +.nf + none - No pixel masking + goodvalue - good pixels defined by maskvalue parameter + badvalue - bad pixels defined by maskvalue parameter + novalue - pixels with no value defined by maskvalue parameter + goodbits - good pixels defined by maskvalue parameter + badbits - bad pixels defined by maskvalue parameter +.fi + +Except for "none", these choices use the mask specified by the header +keyword BPM. To use a different keyword to specify the mask the syntax +is + +.nf + ! [goodvalue|badvalue|novalue|goodbits|badbits] +.fi + +where if the optional second word is missing the default is "goodvalue". + +If "none" (or "") no pixel masking is done +even if an image has an associated pixel mask. The masking defines +pixels to be used (good) and not used (bad). The types use the +"maskvalue" parameter to define a single value (either as a number or +set of bits) for good or bad and all other values are treated as the +opposite; i.e. bad or good respectively. + +The "novalue" choice uses 0 as the good value and all other values are +bad. However, the "maskvalue" parameter defines a mask value for pixels +with no value such as occurs from rebinning at the edges or stacking where +there is no overlap at all. The distinction pixels is that when a final pixel +has no overlapping data because all input pixels have a "no value" flag +the blank value is output while if there is no good data then pixels which +are have other than the "no value" flag are combined as if they were good +to produce a representative output value. An output mask will have a +value of 0 for pixels where at least one good input value was present, +a value of 1 when there was no overlapping data, and a value of 2 when +bad data was used. +.le +.ls maskvalue = 0 +Mask value used with the \fImasktype\fR parameter. If the mask type +selects good or bad bits the value may be specified using IRAF notation +for decimal, octal, or hexadecimal; i.e 12, 14b, 0cx to select bits 3 +and 4. +.le +.ls blank = 0. +Output value to be used when there are no pixels for combining after any +rejection. +.le + +.ls scale = "none" (none|mode|median|mean|exposure|@|!) +Multiplicative image scaling to be applied. The choices are none, multiply +by the reciprocal of the mode, median, or mean of the specified statistics +section, multiply by the reciprocal of the exposure time in the image header, +multiply by the values in a specified file, or multiply by a specified +image header keyword. When specified in a file the scales must be one per +line in the order of the input images. +.le +.ls zero = "none" (none|mode|median|mean|@|!) +Additive zero level image shifts to be applied. The choices are none, add +the negative of the mode, median, or mean of the specified statistics +section, add the values given in a file, or add the values given by an +image header keyword. When specified in a file the zero values must be one +per line in the order of the input images. File or keyword zero offset +values do not allow a correction to the weights. +.le +.ls weight = "none" (none|mode|median|mean|exposure|@|!) +Weights to be applied during the final averaging. The choices are none, +the mode, median, or mean of the specified statistics section, the exposure +time, values given in a file, or values given by an image header keyword. +When specified in a file the weights must be one per line in the order of +the input images and the only adjustment made by the task is for the number of +images previously combined. In this case the weights should be those +appropriate for the scaled images which would normally be the inverse +of the variance in the scaled image. +.le +.ls statsec = "" +Section of images to use in computing image statistics for scaling and +weighting. If no section is given then the entire region of the input is +sampled (for efficiency the images are sampled if they are big enough). +When the images are offset relative to each other one can precede the image +section with one of the modifiers "input", "output", "overlap". The first +interprets the section relative to the input image (which is equivalent to +not specifying a modifier), the second interprets the section relative to +the output image, and the last selects the common overlap and any following +section is ignored. +.le +.ls expname = "" +Image header keyword to be used with the exposure scaling and weighting +options. Also if an exposure keyword is specified that keyword will be +added to the output image using a weighted average of the input exposure +values. +.le + +.ce +Algorithm Parameters +.ls lthreshold = INDEF, hthreshold = INDEF +Low and high thresholds to be applied to the input pixels. This is done +before any scaling, rejection, and combining. If INDEF the thresholds +are not used. +.le +.ls nlow = 1, nhigh = 1 (minmax) +The number of low and high pixels to be rejected by the "minmax" algorithm. +These numbers are converted to fractions of the total number of input images +so that if no rejections have taken place the specified number of pixels +are rejected while if pixels have been rejected by masking, thresholding, +or non-overlap, then the fraction of the remaining pixels, truncated +to an integer, is used. +.le +.ls nkeep = 1 +The minimum number of pixels to retain or the maximum number to reject +when using the clipping algorithms (ccdclip, crreject, sigclip, +avsigclip, or pclip). When given as a positive value this is the minimum +number to keep. When given as a negative value the absolute value is +the maximum number to reject. The latter is in addition to pixels +missing due to non-overlapping offsets, bad pixel masks, or thresholds. +.le +.ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) +Use the median as the estimate for the true intensity rather than the +average with high and low values excluded in the "ccdclip", "crreject", +"sigclip", and "avsigclip" algorithms? The median is a better estimator +in the presence of data which one wants to reject than the average. +However, computing the median is slower than the average. +.le +.ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) +Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", +"avsigclip", and "pclip" algorithms. They multiply a "sigma" factor +produced by the algorithm to select a point below and above the average or +median value for rejecting pixels. The lower sigma is ignored for the +"crreject" algorithm. +.le +.ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) +Readout noise in electrons, gain in electrons/DN, and sensitivity noise as +a fraction. These parameters are used with the "ccdclip" and "crreject" +algorithms as well as with the "nmodel" combining option. The values may +be either numeric or an image header keyword which contains the value. +The noise model for a pixel is: + +.nf + variance in DN = (rdnoise/gain)^2 + DN/gain + (snoise*DN)^2 + variance in e- = (rdnoise)^2 + (gain*DN) + (snoise*(gain*DN))^2 + = rdnoise^2 + Ne + (snoise * Ne)^2 +.fi + +where DN is the data number and Ne is the number of electrons. Sensitivity +noise typically comes from noise introduced during flat fielding. +.le +.ls sigscale = 0.1 (ccdclip, crreject, sigclip, avsigclip) +This parameter determines when poisson corrections are made to the +computation of a sigma for images with different scale factors. If all +relative scales are within this value of unity and all relative zero level +offsets are within this fraction of the mean then no correction is made. +The idea is that if the images are all similarly though not identically +scaled, the extra computations involved in making poisson corrections for +variations in the sigmas can be skipped. A value of zero will apply the +corrections except in the case of equal images and a large value can be +used if the sigmas of pixels in the images are independent of scale and +zero level. +.le +.ls pclip = -0.5 (pclip) +Percentile clipping algorithm parameter. If greater than +one in absolute value then it specifies a number of pixels above or +below the median to use for computing the clipping sigma. If less +than one in absolute value then it specifies the fraction of the pixels +above or below the median to use. A positive value selects a point +above the median and a negative value selects a point below the median. +The default of -0.5 selects approximately the quartile point. +See the DESCRIPTION section for further details. +.le +.ls grow = 0. +Radius in pixels for additional pixel to be rejected in an image with a +rejected pixel from one of the rejection algorithms. This applies only to +pixels rejected by one of the rejection algorithms and not the masked or +threshold rejected pixels. +.le + +.ce +Environment Variables + +.ls imcombine_maxmemory (default = 250000000) +This task tries to use the maximum possible memory for efficiency when +dealing with lots of data and is designed to reduce memory usage if +memory allocation fails. However, there may be cases where this adjustment +fails so this variable allows forcing the task to stay within a smaller +allocation. This variable is in bytes and the default is the amount +generally returned by the system. It is large because of virtual memory +functionality. If problems are encountered one should try setting this +variable to a smaller size until, hopefully, the out of memory errors +disappear. +.le +.ls imcombine_option (default = 1) +This environment variable is used to select certain experimental or +diagnostic options. If this variable has the value 1, the default when the +variable is undefined, then when the number of images exceeds the number of +files that can be kept open under IRAF (currently this means more than 4000 +images) the images are closed and opened as needed. This is in contrast to +the previous method, when the variable has the value 0, which first builds +a single stacked image of a higher dimension from the input images. This +method requires the images all have the same size and also that there be +sufficient disk space for the stacked image and that the image be less +than 2Gb in size. +.le +.ih +DESCRIPTION +A set of images or the highest dimension elements (for example +the planes in an image cube) are combined by weighted averaging, medianing, +or summing. Pixels may be rejected from the combining by using pixel +masks, threshold levels, and rejection algorithms. The images may be +scaled, before rejections, multiplicatively, additively, or both based on +image statistics, image header keywords, or text files. The images may be +combined with integer pixel coordinate offsets, possibly determined using +the world coordinate system of the images, to produce an image bigger than +any of the input images. + +The input images to be combined are specified by a list. If the +\fBproject\fR parameter is "yes" then the highest dimension elements of +each input image are combined to make an output image of one lower +dimension. There is no limit to the number of elements combined in this +case. If \fBproject\fR is "no" then the entire input list is combined to +form a single output image. In this case the images must all have the +same dimensionality but they may have different sizes. There is a software +limit of approximately 4000 images which may be open +simultaneously. To combine more than this number the program may either +create a temporary stacked image, requiring the images to be of the same +size, or repeatedly open and close the images. See the "Environment +Variables" in the PARAMETERS section. + +The output image header is a copy of the first image in the combined set. +In addition, the number of images combined is recorded under the keyword +NCOMBINE. The value of a keyword in the input images, where the +keyword is specified by the parameter \fIimcmb\fR, is written to an +indexed keyword IMCMBnnn. The purpose of the ICMBnnn keywords is to +identify the contributors to the output image. One common choice is +the input image name though other identifiers may be used. + +If a bad pixel mask is created, the name of the mask will be included in the +output image header under the keyword BPM. The output pixel type is set by +the parameter \fIouttype\fR. If left blank then the input datatype of +highest precision is used. If there is a mixture of short and unsigned +short images then the highest precision is integer. + +In addition to one or more output combined images there are some optional +output files which may be specified as described in the OPTIONAL OUTPUT +section. + +An outline of the steps taken by the program is given below and the +following sections elaborate on the steps. + +.nf +o Check the input images and stack them if needed +o Set the input image offsets and the final output image size. +o Set the input image scales and weights possibly by computing + image statistics +o Write the log file and optional header output +.fi + +For each output image line: + +.nf +o Get input image lines that overlap the output image line +o Reject masked pixels +o Reject pixels outside the threshold limits +o Reject pixels using the specified algorithm +o Reject neighboring pixels along each line +o Combine remaining pixels using the weighted average or median +o Compute sigmas of remaining pixels about the combined values +o Write the output image line and other optional images. +.fi + +OPTIONAL OUTPUTS + +There are various additional outputs that may be produced by providing +the filenames. + +.ls Headers +The output image can only have one set of header keywords which are +inherited from the first input image in the input list. Copies of all the +input headers may be stored in a multiextension FITS file specified by the +\fIheaders\fR parameter. The extension names are the input image names. +The extensions are dataless headers. Since this means the image sizes are +lost, AXLEN keywords are added. Also the keywords INIMAGE and OUTIMAGE are +added giving the name of the input image and the name of the output +combined image. +.le +.ls Bad Pixel Masks +The \fIbpmasks\fR parameter produces optional output bad pixel mask(s) with +good values of 0 and bad values of 1. Output pixels are marked as bad when +no input pixels contributed to the output pixel. The file name is also +added to the output image header under the keyword BPM. +.le +.ls Rejection Masks +The \fIrejmasks\fR parameter produces optional output mask file(s) +identifying rejected or excluded pixels. The pixel mask is the size of the +output image. There is one extra dimension with length equal to the number +of input images. Each element of the highest dimension is a mask +corresponding to an input image with values of 1 for rejected or excluded +pixels and values of 0 for pixels which were used. The order of the masks +is the order of the input images and image header keywords indexed by the +element identify the input images. Note that the pixel positions are in +the output pixel coordinate system. + +This mask is the only way to record whether a particular input image pixel +contributed to the output image. As an example, consider the case of +three input two dimensional images of sizes 1020x1020, 1010x1010, and +1000x1000 with relative offsets of (0,0), (10,10), and (20,20). The output +image would then be 1020x1020. + +Suppose that the only input pixels not used are pixels (1,1) in each input +image. Because of the offsets the first 10 rows and columns of the output +will be based on just a single pixel except for (1,1) which has no input +pixels. The next 10 rows and columns of the output will be a combination +of 2 input pixels except (11,11) which is just based on pixel (11,11) +in the first input image. Finally all other pixels except (21,21) will be +a combination of 3 values. + +The rejection mask will be three dimensional of size 1020x1020x3. Plane 1 +will correspond to the first input image, plane 2 to the second, and so +on. All of the pixels will be zero except for the following pixels +which will have a value of 1. In the first plane only pixel (1,1,1) will be +one. In the second plane the first 10 rows and columns and pixel (11,11,2) +will be one. And in the third plane, the first 20 rows and columns and pixel +(21,21,3) will be one. So if we want to know about output pixel (11,11) +the rejection mask will tell us that pixels from the second and third +images were excluded. + +This is a complex example because of the offsets and dissimilar sizes. +In the more common and simpler case of equal sizes and registered images, +the mask +planes would have one to indicate that the pixel in the input image at +that coordinate was not used. For instance if pixel (12,15,2) is one +in the rejection mask then pixel (12,15) in the second input image was +excluded. + +Note that one can use image sections to extract a mask matching the input +image. For the example case with the offsets masks in the input +coordinates can be extracted with the commands + +.nf + cl> imcopy rejmask[*,*,1] mask1 + cl> imcopy rejmask[11:1020,11:1020,2] mask2 + cl> imcopy rejmask[21:1020,21:1020,3] mask3 +.fi + +For the case of equal sized and registered images one could also use +\fBimslice\fR. +.le +.ls Mask of the Number of Rejected Pixels +The \fInrejmasks\fR parameter produces optional pixel mask(s) giving the +number of input pixels rejected or excluded from the input images. This is +equivalent to projecting the rejection mask described previously by summing +along the highest dimension. Note that in this mask a value of 0 indicates +all the input pixels were used to create the output pixel and a value equal +to the number of input images indicate no input pixels were used. +.le +.ls Exposure Masks +The \fIexpmasks\fR parameter produces optional output exposure mask(s) +giving the sum of the exposure values of the input images with non-zero +weights that contributed to that pixel. Since masks are integer, the +exposure values may be scaled to preserve dynamic range and fractional +significance. The scaling values are given in the header under the +keywords MASKSCAL and MASKZERO. Exposure values are computed from the mask +values by scale * value + zero where scale is the value of the MASKSCAL +keyword and zero is the value of the MASKZERO keyword. +.le +.ls Sigma of Combined Pixels +The \fIsigma\fR parameter produces optional output sigma image(s). The +sigma is the standard deviation, corrected for a finite population, of the +input pixel values (excluding rejected pixels) about the output combined +pixel values. +.le +.ls Output Log File +The \fIlogfile\fR parameter produces an optional output log file. If no +file is specified then no log information is produced. The special +filename "STDOUT" prints log information to the terminal. +.le + +OFFSETS + +The images to be combined need not be of the same size or overlap. They +do have to have the same dimensionality which will also be the dimensionality +of the output image. Any dimensional images supported by IRAF may be +used. Note that if the \fIproject\fR flag is "yes" then the input images +are the elements of the highest dimension; for example the planes of a +three dimensional image. + +The overlap of the images is determined by a set of integer pixel offsets +with an offset for each dimension of each input image. For example +offsets of 0, 10, and 20 in the first dimension of three images will +result in combining the three images with only the first image in the +first 10 columns, the first two images in the next 10 columns and +all three images starting in the 21st column. At the 21st output column +the 21st column of the first image will be combined with the 11th column +of the second image and the 1st column of the third image. + +The output image size is set by the maximum extent in each dimension +of any input image after applying the offsets. In the above example if +all the images have 100 columns then the output image will have 120 +columns corresponding to the 20 column offset in the third image. +Note that this same output image size is computed and used as the +basis for the \fIoutlimits\fR parameter to specify a subregion to +actually be output. + +The input image offsets are set using the \fIoffset\fR parameter. There +are four ways to specify the offsets. If the word "none" or the empty +string "" are used then all offsets will be zero and all pixels with the +same coordinates will be combined. The output image size will be equal to +the biggest dimensions of the input images. + +If "wcs" offsets are specified then the world coordinate systems (wcs) +in the image headers are used to derived the offsets. The world coordinate +at the center of the first input image is evaluated. Then integer pixel +offsets are determined for each image to bring the same world coordinate +to the same point. Note the following caveats. The world coordinate +systems must be of the same type, orientation, and scale and only the +nearest integer shift is used. + +If the input images have offsets in a regular grid or one wants to make +an output image in which the input images are "mosaiced" together in +a grid then the special offset string beginning with the word "grid" +is used. The format is + +.nf + grid [n1] [s1] [n2] [s2] ... +.fi + +where ni is the number of images in dimension i and si is the step in +dimension i. For example "grid 5 100 5 100" specifies a 5x5 grid with +origins offset by 100 pixels. Note that one must insure that the input +images are specified in the correct order. This may best be accomplished +using a "@" list. One useful application of the grid is to make a +non-overlapping mosaic of a number of images for display purposes. Suppose +there are 16 images which are 100x100. The offset string "grid 4 101 4 +101" will produce a mosaic with a one pixel border having the value set +by \fIblank\fR parameter between the images. + +The offsets may be defined in a file by specifying the file name +in the \fIoffset\fR parameter. (Note that the special file name STDIN +may be used to type in the values terminated by the end-of-file +character). The file consists of a line for each input image. The lines +must be in the same order as the input images and so an "@" list may +be useful. The lines consist of whitespace separated offsets one for +each dimension of the images. In the first example cited above the +offset file might contain: + +.nf + 0 0 + 10 0 + 20 0 +.fi + +where we assume the second dimension has zero offsets. + +The offsets need not have zero for one of the images. The offsets may +include negative values or refer to some arbitrary common point. +When the offsets are read by the program it will find the minimum +value in each dimension and subtract it from all the other offsets +in that dimension. The above example could also be specified as: + +.nf + 225 15 + 235 15 + 245 15 +.fi + +There may be cases where one doesn't want the minimum offsets reset +to zero. If all the offsets are positive and the comment "# Absolute" +appears in the offset file then the images will be combined with +blank values between the first output pixel and the first overlapping +input pixel. Continuing with the above example, the file + +.nf + # Absolute + 10 10 + 20 10 + 30 10 +.fi + +will have the first pixel of the first image in the 11th pixel of the +output image. Note that there is no way to "pad" the other side of +the output image. + +OUTPUT OF SUBREGIONS + +The output image size is computed from all of the input images including +the offsets as described previously. The \fIoutlimits\fR may be used to +specify a subregion of this full size to be created. The syntax of this +parameter is pairs of whitespace separated numbers selecting the first and last +pixel in each output dimension. The pairs for each dimension are also +whitespace separated and are given in order of the dimensions. Any missing +values at the end of the string default to the full limits of the output +image. If the requested limits fall outside the full output image they are +reset to the size of the full computed output size. + +As an example, consider combining 10 images of size 1000x1000 with offsets +of 0, 1, ..., 9 along the first dimension. Because of the offsets the full +output size is 1010x1000. To output only the region [1:100,101:200] +of this full size the parameter value would be the string "1 100 101 200". +Note that if the value was just "1 100" then the output region would +be [1:100,1:1000]. + +The intended purpose for this option is to allow creating subregions using +a smaller number of images in the case of offset data taken at a raster of +positions. This is important since when the number of images becomes too +large (>4000) the program either has to prestack the images into a higher +dimensional single image (requiring equal sized images) or utilize an +inefficient algorithm where images are opened and closed for each input +line. A detail of how this task works is that it is the number of images +required to be accessed for each output line that is significant. + +The following example was developed when the maximum number of images +open at one time was ~240. In V2.12 the number was increased to +more than 4000 so it is not as relevant though it may apply to very +large surveys with many small images. + +As an example, consider a survey of a region of the sky composed of 8000 +images which are each 500x1000. The offsets between each image are 50 +pixels along the first dimension and 900 pixels along the second dimension, +give or take a few pixels due to telescope pointing errors. Thus this +survey consists of strips of exposures. Within a strip the images over by +about 450 pixels. Between strips the overlap is 100 pixels. So the +strips consist 400 exposures and there are 20 strips. + +The full size of this survey is then about 20450x18900. At any point in a +single strip the number of images contributing is no more than 10. +Including the overlap of the strips the maximum number is then 20. In +order to combine the data for such a survey one would like to create +subregion outputs which are 120 images from each strip. The lines where +the two strips overlap then require 240 images. To produce roughly equal +size regions we choose sizes along the first dimension of 5200 pixels. The +number of lines in the output subregions might be the full size of the +survey. However, it might be desirable to also break the second dimension +into blocks for ease of display and manipulation. + +The method for combining this example survey is then to combine the data in +four groups along the first dimension to produce subimages each 5200 pixels +wide which have no overlap. The reason for wanting to create +non-overlapping subregions is to simplify creation of the related masks, +most importantly, the exposure masks. The \fIoutlimits\fR parameter would +have the values "1 5200", "5201 10400", "10401 15600", and "15601 20800". +The second pair of limits is not specified to obtain the full size along +the second dimension. Note that the last block will actually be smaller +than 5200 pixels since the survey is less than 20800 pixels. + +In each combining step all the images must be specified for the input in +order to compute the full output size but then only those images needed to +produce an output line will be accessed at the same time. By design this +is roughly 240 images for lines where the strips overlap. The +non-overlapping blocks can be mosaiced together with this task as a final +step if desired. + + +SCALES AND WEIGHTS + +In order to combine images with rejection of pixels based on deviations +from some average or median they must be scaled to a common level. There +are two types of scaling available, a multiplicative intensity scale and an +additive zero point shift. The intensity scaling is defined by the +\fIscale\fR parameter and the zero point shift by the \fIzero\fR +parameter. These parameters may take the values "none" for no scaling, +"mode", "median", or "mean" to scale by statistics of the image pixels, +"exposure" (for intensity scaling only) to scale by the exposure time +keyword in the image header, any other image header keyword specified by +the keyword name prefixed by the character '!', and the name of a file +containing the scale factors for the input image prefixed by the +character '@'. + +Examples of the possible parameter values are shown below where +"myval" is the name of an image header keyword and "scales.dat" is +a text file containing a list of scale factors. + +.nf + scale = none No scaling + zero = mean Intensity offset by the mean + scale = exposure Scale by the exposure time + zero = !myval Intensity offset by an image keyword + scale = @scales.dat Scales specified in a file +.fi + +The image statistics are computed by sampling a uniform grid of points with +the smallest grid step that yields less than 100000 pixels; sampling is used +to reduce the time needed to compute the statistics. If one wants to +restrict the sampling to a region of the image the \fIstatsec\fR parameter +is used. This parameter has the following syntax: + +.nf + [input|output|overlap] [image section] +.fi + +The initial modifier defaults to "input" if absent. The modifiers are useful +if the input images have offsets. In that case "input" specifies +that the image section refers to each input image, "output" specifies +that the image section refers to the output image coordinates, and +"overlap" specifies the mutually overlapping region of the input images. +In the latter case an image section is ignored. + +The statistics are as indicated by their names. In particular, the +mode is a true mode using a bin size which is a fraction of the +range of the pixels and is not based on a relationship between the +mode, median, and mean. Also masked pixels are excluded from the +computations as well as during the rejection and combining operations. + +The "exposure" option in the intensity scaling uses the value of the +image header keyword specified by the \fIexpname\fR keyword. As implied +by the parameter name, this is typically the image exposure time since +intensity levels are linear with the exposure time in CCD detectors. +Note that the exposure keyword is also updated in the final image +as the weighted average of the input values. Thus, if one wants to +use a nonexposure time keyword and keep the exposure time updating +feature the image header keyword syntax is available; i.e. !. + +Scaling values may be defined as a list of values in a text file. The file +name is specified by the standard @file syntax. The list consists of one +value per line. The order of the list is assumed to be the same as the +order of the input images. It is a fatal error if the list is incomplete +and a warning if the list appears longer than the number of input images. +Because the scale and zero levels are adjusted only the relative +values are important. + +If both an intensity scaling and zero point shift are selected the +zero point is added first and the scaling is done. This is +important if the scale and offset values are specified by +header keywords or from a file of values. However, +in the log output the zero values are given as the scale times +the offset hence those numbers would be interpreted as scaling +first and zero offset second. + +The image statistics and scale factors are recorded in the log file +unless they are all equal, which is equivalent to no scaling. The +scale factors are normalized so that the first input image has no +scaling. This is done because the header of the first input image +is used as the template header for the combined output image. +By scaling to this first image this means that flux related keywords, +such as exposure time and airmass, are representative of the output +(except when the "sum" option is used). + +Scaling affects not only the mean values between images but also the +relative pixel uncertainties. For example scaling an image by a +factor of 0.5 will reduce the effective noise sigma of the image +at each pixel by the square root of 0.5. Changes in the zero +point also changes the noise sigma if the image noise characteristics +are Poissonian. In the various rejection algorithms based on +identifying a noise sigma and clipping large deviations relative to +the scaled median or mean, one may need to account for the scaling induced +changes in the image noise characteristics. + +In those algorithms it is possible to eliminate the "sigma correction" +while still using scaling. The reasons this might be desirable are 1) if +the scalings are similar the corrections in computing the mean or median +are important but the sigma corrections may not be important and 2) the +image statistics may not be Poissonian, either inherently or because the +images have been processed in some way that changes the statistics. In the +first case because computing square roots and making corrections to every +pixel during the iterative rejection operation may be a significant +computational speed limit the parameter \fIsigscale\fR selects how +dissimilar the scalings must be to require the sigma corrections. This +parameter is a fractional deviation which, since the scale factors are +normalized to unity, is the actual minimum deviation in the scale factors. +For the zero point shifts the shifts are normalized by the mean shift +before adjusting the shifts to a zero mean. To always use sigma scaling +corrections the parameter is set to zero and to eliminate the correction in +all cases it is set to a very large number. + +If the final combining operation is "average" then the images may be +weighted during the averaging. The weights are specified in the same way +as the scale factors. In addition the NCOMBINE keyword, if present, will +be used in the weights. The weights, scaled to a unit sum, are printed in +the log output. + +The weights are used for the final weighted average, sigma image, and +exposure mask output. They are not used to form averages in the various +rejection algorithms. For weights in the case of no scaling or only +multiplicative scaling the weights are used as given or determined so that +images with lower signal levels will have lower weights. However, for +cases in which zero level scaling is used and the zero levels are +determined from image statistics (not from an input file or keyword) the +weights are computed from the initial weights (the exposure time, image +statistics, or input values) using the formula: + +.nf + weight_final = weight_initial / (scale * sky) +.fi + +where the sky values are those from the image statistics before conversion +to zero level shifts and adjustment to zero mean over all images. The +reasoning is that if the zero level is high the sky brightness is high and +so the S/N is lower and the weight should be lower. If any sky value +determined from the image statistics comes out to be negative a warning is +given and the none of the weight are adjusted for sky levels. + +The weights are not adjusted when the zero offsets are input from a file +or keyword since these values do not imply the actual image sky value. +In this case if one wants to account for different sky statistics +in the weights the user must specify the weights in a file taking +explicit account of changes in the weights due to different sky +statistics. + +When forming the final weighted averages if the sum of the weights of +the non-rejected or excluded pixels is zero then instead of producing +a zero average the unweighted average of the pixels is produced. Similarly, +in the sigma calculation when the weights of the pixels are all zero +then the sigma is computed as if all pixels have unit weights. + +When there are zero weights only the pixels with non-zero weights are +used in computing the output exposure time mask. Note that the actual +weight values are not used but simply the sum of all exposure times +of pixels from images with non-zero weights is produced. + +The purpose of using zero weights is to identify images that are of +poor quality (such as non-photometric or bad seeing) which are then +excluded in the final weighted average or exposure time. However, +they contribute to the final image when there is no good +quality data but with an output exposure time of zero. + +INPUT PIXEL MASKS + +A pixel mask is a type of IRAF file having the extension ".pl" or +a FITS extension of "type=mask" which +identifies an integer value with each pixel of the images to which it is +applied. In future masks may also be stored as special FITS extensions. +The integer values may denote regions, a weight, a good or bad +flag, or some other type of integer or integer bit flag. In the common +case where many values are the same, this type of file is compact. +It is most compact and efficient if the majority of +the pixels have a zero mask value so frequently zero is the value for good +pixels. Note that these files, while not stored as a strict pixel array, +may be treated as images in programs. This means they may be created by +programs such as \fBmkpattern\fR, edited by \fBimedit\fR, examined by +\fBimexamine\fR, operated upon by \fBimarith\fR, graphed by \fBimplot\fR, +and displayed by \fBdisplay\fR. + +To use pixel masks with \fBimcombine\fR one must associate a pixel +mask file with an image by entering the pixel list file name in the +image header under the keyword BPM (bad pixel mask) or some other +keyword to be specified. This can be +done with \fBhedit\fR. Note that the same pixel mask may be associated +with more than one image as might be the case if the mask represents +defects in the detector used to obtain the images. + +If a pixel mask is associated with an image the mask is used when the +\fImasktype\fR parameter is set to a value other than "none" or "". Note that +when it is set to "none", mask information is not used even if it exists for +the image. The values of \fImasktype\fR which apply masks are "goodvalue", +"badvalue", "novalue", "goodbits", "badbits", and "!". The last choice +allows specifying the keyword whose value is the mask to be used otherwise +the keyword "BPM" is used. + +The \fImasktype\fR choices are used in conjunction with the +\fImaskvalue\fR parameter. When the mask type is "goodvalue" or an +explicit keyword is specified without a mask type, the pixels with mask +values matching the specified value are included in combining and all +others are rejected. For a mask type of "badvalue" the pixels with +mask values matching the specified value are rejected and all others +are accepted. The bit types are useful for selecting a combination of +attributes in a mask consisting of bit flags. The mask value is still +an integer but is interpreted by bitwise comparison with the values in +the mask file. + +The "novalue" option differs from the others in that there are three +classes of mask values and any output pixel mask will have the three +values 0 for good, 1 for no data, and 2 for bad. The purpose of this +option is to produce output values from the input values when there are +no good pixels. This happens when the input images have pixel values +which have been identified as bad (such as saturated) but whose values +can be used, possibly after being replaced or interpolated from nearby +pixels, to produce a value that is either cosmetically reasonable or even +marginally scientifically useful. Again, this only happens if there +are no good pixels to combine and then the output mask will identify +these pixels with a mask value of 2. If there is even one good pixel +then only the good data will contribute to the output. An exposure mask +may be useful in this case when most but not all image pixels have been +eliminated due to things like saturation. + +If a mask operation is specified and an image has no mask image associated +with it (the BPM or specified keyword is absent), the mask values are taken +as all zeros. In those cases be careful that zero is an accepted value +otherwise the entire image will be rejected. + +When the number of input images exceeds the maximum number of open files +allowed by IRAF and the input images need to be "stacked" then the masks +are also stacked. The stacking requires all the images to have the same size. + + +THRESHOLD REJECTION + +In addition to rejecting masked pixels, pixels in the unscaled input +images which are below or above the thresholds given by the parameters +\fIlthreshold\fR and \fIhthreshold\fR are rejected. Values of INDEF +mean that no threshold value is applied. Threshold rejection may be used +to exclude very bad pixel values or as an alternative way of masking +images. In the latter case one can use a task like \fBimedit\fR +or \fBimreplace\fR to set parts of the images to be excluded to some +very low or high magic value. + + +REJECTION ALGORITHMS + +The \fIreject\fR parameter selects a type of rejection operation to +be applied to pixels not masked or thresholded. If no rejection +operation is desired the value "none" is specified. + +.in 2 +MINMAX +.in 2 +A specified fraction of the highest and lowest pixels are rejected. +The fraction is specified as the number of high and low pixels, the +\fInhigh\fR and \fInlow\fR parameters, when data from all the input images +are used. If pixels have been rejected by offseting, masking, or +thresholding then a matching fraction of the remaining pixels, truncated +to an integer, are used. Thus, + +.nf + nl = n * nlow/nimages + 0.001 + nh = n * nhigh/nimages + 0.001 +.fi + +where n is the number of pixels surviving offseting, masking, and +thresholding, nimages is the number of input images, nlow and nhigh +are task parameters and nl and nh are the final number of low and +high pixels rejected by the algorithm. The factor of 0.001 is to +adjust for rounding of the ratio. + +As an example with 10 input images and specifying one low and two high +pixels to be rejected the fractions to be rejected are nlow=0.1 and nhigh=0.2 +and the number rejected as a function of n is: + +.nf + n 0 1 2 3 4 5 6 7 8 9 10 + nl 0 0 0 0 0 0 0 0 0 0 1 + nh 0 0 0 0 0 1 1 1 1 1 2 +.fi + +.in -2 +CCDCLIP +.in 2 +If the images are obtained using a CCD with known read out noise, gain, and +sensitivity noise parameters and they have been processed to preserve the +relation between data values and photons or electrons then the noise +characteristics of the images are well defined. In this model the sigma in +data values at a pixel with true value , as approximated by the median +or average with the lowest and highest value excluded, is given by: + +.nf + sigma = ((rn / g) ** 2 + / g + (s * ) ** 2) ** 1/2 +.fi + +where rn is the read out noise in electrons, g is the gain in +electrons per data value, s is a sensitivity noise given as a fraction, +and ** is the exponentiation operator. Often the sensitivity noise, +due to uncertainties in the pixel sensitivities (for example from the +flat field), is not known in which case a value of zero can be used. +See the task \fBstsdas.wfpc.noisemodel\fR for a way to determine +these values (though that task expresses the read out noise in data +numbers and the sensitivity noise parameter as a percentage). + +The read out noise is specified by the \fIrdnoise\fR parameter. The value +may be a numeric value to be applied to all the input images or a image +header keyword containing the value for each image. Similarly, the +parameter \fIgain\fR specifies the gain as either a value or image header +keyword and the parameter \fIsnoise\fR specifies the sensitivity +noise parameter as either a value or image header keyword. + +The algorithm operates on each output pixel independently. It starts by +taking the median or unweighted average (excluding the minimum and maximum) +of the unrejected pixels provided there are at least two input pixels. The +expected sigma is computed from the CCD noise parameters and pixels more +that \fIlsigma\fR times this sigma below or \fIhsigma\fR times this sigma +above the median or average are rejected. The process is then iterated +until no further pixels are rejected. If the average is used as the +estimator of the true value then after the first round of rejections the +highest and lowest values are no longer excluded. Note that it is possible +to reject all pixels if the average is used and is sufficiently skewed by +bad pixels such as cosmic rays. + +If there are different CCD noise parameters for the input images +(as might occur using the image header keyword specification) then +the sigmas are computed for each pixel from each image using the +same estimated true value. + +If the images are scaled and shifted and the \fIsigscale\fR threshold +is exceedd then a sigma is computed for each pixel based on the +image scale parameters; i.e. the median or average is scaled to that of the +original image before computing the sigma and residuals. + +After rejection the number of retained pixels is checked against the +\fInkeep\fR parameter. If there are fewer pixels retained than specified +by this parameter the pixels with the smallest residuals in absolute +value are added back. If there is more than one pixel with the same +absolute residual (for example the two pixels about an average +or median of two will have the same residuals) they are all added +back even if this means more than \fInkeep\fR pixels are retained. +Note that the \fInkeep\fR parameter only applies to the pixels used +by the clipping rejection algorithm and does not apply to threshold +or bad pixel mask rejection. + +This is the best clipping algorithm to use if the CCD noise parameters are +adequately known. The parameters affecting this algorithm are \fIreject\fR +to select this algorithm, \fImclip\fR to select the median or average for +the center of the clipping, \fInkeep\fR to limit the number of pixels +rejected, the CCD noise parameters \fIrdnoise, gain\fR and \fIsnoise\fR, +\fIlsigma\fR and \fIhsigma\fR to select the clipping thresholds, +and \fIsigscale\fR to set the threshold for making corrections to the sigma +calculation for different image scale factors. + +.in -2 +CRREJECT +.in 2 +This algorithm is identical to "ccdclip" except that only pixels above +the average are rejected based on the \fIhsigma\fR parameter. This +is appropriate for rejecting cosmic ray events and works even with +two images. + +.in -2 +SIGCLIP +.in 2 +The sigma clipping algorithm computes at each output pixel the median or +average excluding the high and low values. The sigma is then computed +about this estimate (without excluding the low and high values). There +must be at least three input pixels, though for this method to work well +there should be at least 10 pixels. Values deviating by more than the +specified sigma threshold factors are rejected. These steps are repeated, +except that after the first time the average includes all values, until no +further pixels are rejected or there are fewer than three pixels. + +After rejection the number of retained pixels is checked against the +\fInkeep\fR parameter. If there are fewer pixels retained than specified +by this parameter the pixels with the smallest residuals in absolute +value are added back. If there is more than one pixel with the same +absolute residual (for example the two pixels about an average +or median of two will have the same residuals) they are all added +back even if this means more than \fInkeep\fR pixels are retained. +Note that the \fInkeep\fR parameter only applies to the pixels used +by the clipping rejection algorithm and does not apply to threshold +or bad pixel mask rejection. + +The parameters affecting this algorithm are \fIreject\fR to select +this algorithm, \fImclip\fR to select the median or average for the +center of the clipping, \fInkeep\fR to limit the number of pixels +rejected, \fIlsigma\fR and \fIhsigma\fR to select the +clipping thresholds, and \fIsigscale\fR to set the threshold for +making corrections to the sigma calculation for different image scale +factors. + +.in -2 +AVSIGCLIP +.in 2 +The averaged sigma clipping algorithm assumes that the sigma about the +median or mean (average excluding the low and high values) is proportional +to the square root of the median or mean at each point. This is +described by the equation: + +.nf + sigma(column,line) = sqrt (gain(line) * signal(column,line)) +.fi + +where the \fIestimated\fR signal is the mean or median (hopefully excluding +any bad pixels) and the gain is the \fIestimated\fR proportionality +constant having units of photons/data number. + +This noise model is valid for images whose values are proportional to the +number of photons recorded. In effect this algorithm estimates a +detector gain for each line with no read out noise component when +information about the detector noise parameters are not known or +available. The gain proportionality factor is computed +independently for each output line by averaging the square of the residuals +(at points having three or more input values) scaled by the median or +mean. In theory the proportionality should be the same for all rows but +because of the estimating process will vary somewhat. + +Once the proportionality factor is determined, deviant pixels exceeding the +specified thresholds are rejected at each point by estimating the sigma +from the median or mean. If any values are rejected the median or mean +(this time not excluding the extreme values) is recomputed and further +values rejected. This is repeated until there are no further pixels +rejected or the number of remaining input values falls below three. Note +that the proportionality factor is not recomputed after rejections. + +If the images are scaled differently and the sigma scaling correction +threshold is exceedd then a correction is made in the sigma +calculations for these differences, again under the assumption that +the noise in an image scales as the square root of the mean intensity. + +After rejection the number of retained pixels is checked against the +\fInkeep\fR parameter. If there are fewer pixels retained than specified +by this parameter the pixels with the smallest residuals in absolute +value are added back. If there is more than one pixel with the same +absolute residual (for example the two pixels about an average +or median of two will have the same residuals) they are all added +back even if this means more than \fInkeep\fR pixels are retained. +Note that the \fInkeep\fR parameter only applies to the pixels used +by the clipping rejection algorithm and does not apply to threshold +or bad pixel mask rejection. + +This algorithm works well for even a few input images. It works better if +the median is used though this is slower than using the average. Note that +if the images have a known read out noise and gain (the proportionality +factor above) then the "ccdclip" algorithm is superior. The two algorithms +are related in that the average sigma proportionality factor is an estimate +of the gain. + +The parameters affecting this algorithm are \fIreject\fR to select +this algorithm, \fImclip\fR to select the median or average for the +center of the clipping, \fInkeep\fR to limit the number of pixels +rejected, \fIlsigma\fR and \fIhsigma\fR to select the +clipping thresholds, and \fIsigscale\fR to set the threshold for +making corrections to the sigma calculation for different image scale +factors. + +.in -2 +PCLIP +.in 2 +The percentile clipping algorithm is similar to sigma clipping using the +median as the center of the distribution except that, instead of computing +the sigma of the pixels from the CCD noise parameters or from the data +values, the width of the distribution is characterized by the difference +between the median value and a specified "percentile" pixel value. This +width is then multiplied by the scale factors \fIlsigma\fR and \fIhsigma\fR +to define the clipping thresholds above and below the median. The clipping +is not iterated. + +The pixel values at each output point are ordered in magnitude and the +median is determined. In the case of an even number of pixels the average +of the two middle values is used as the median value and the lower or upper +of the two is the median pixel when counting from the median pixel to +selecting the percentile pixel. The parameter \fIpclip\fR selects the +percentile pixel as the number (if the absolute value is greater +than unity) or fraction of the pixels from the median in the ordered set. +The direction of the percentile pixel from the median is set by the sign of +the \fIpclip\fR parameter with a negative value signifying pixels with +values less than the median. Fractional values are internally converted to +the appropriate number of pixels for the number of input images. A minimum +of one pixel and a maximum corresponding to the extreme pixels from the +median are enforced. The value used is reported in the log output. Note +that the same percentile pixel is used even if pixels have been rejected by +offseting, masking, or thresholding; for example, if the 3nd pixel below +the median is specified then the 3rd pixel will be used whether there are +10 pixels or 5 pixels remaining after the preliminary steps. + +After rejection the number of retained pixels is checked against the +\fInkeep\fR parameter. If there are fewer pixels retained than specified +by this parameter the pixels with the smallest residuals in absolute +value are added back. If there is more than one pixel with the same +absolute residual (for example the two pixels about an average +or median of two will have the same residuals) they are all added +back even if this means more than \fInkeep\fR pixels are retained. +Note that the \fInkeep\fR parameter only applies to the pixels used +by the clipping rejection algorithm and does not apply to threshold +or bad pixel mask rejection. + +Some examples help clarify the definition of the percentile pixel. In the +examples assume 10 pixels. The median is then the average of the +5th and 6th pixels. A \fIpclip\fR value of 2 selects the 2nd pixel +above the median (6th) pixel which is the 8th pixel. A \fIpclip\fR +value of -0.5 selects the point halfway between the median and the +lowest pixel. In this case there are 4 pixels below the median, +half of that is 2 pixels which makes the percentile pixel the 3rd pixel. + +The percentile clipping algorithm is most useful for clipping small +excursions, such as the wings of bright objects when combining +disregistered observations for a sky flat field, that are missed when using +the pixel values to compute a sigma. It is not as powerful, however, as +using the CCD noise parameters (provided they are accurately known) to clip +about the median. + +The parameters affecting this algorithm are \fIreject\fR to select this +algorithm, \fIpclip\fR to select the percentile pixel, \fInkeep\fR to limit +the number of pixels rejected, and \fIlsigma\fR and \fIhsigma\fR to select +the clipping thresholds. +.in -4 + +GROW REJECTION + +Neighbors of pixels rejected by the rejection algorithms +may also be rejected. The number of neighbors to be rejected +is specified by the \fIgrow\fR parameter which is a radius in pixels. +If too many pixels are rejected in one of the grown pixels positions +(as defined by the \fInkeep\fR parameter) then the value of that pixel +without growing will be used. + +COMBINING + +After all the steps of offsetting the input images, masking pixels, +threshold rejection, scaling, and applying a rejection algorithms the +remaining pixels are combined and output as specified by the \fIcombine\fR +parameter. In all cases if there are no remaining pixels the \fIblank\fR +is produced. The combining choices are as follows. + +.in 2 +AVERAGE +.in 2 +The weighted average of the remaining pixels is computed. If no +weighting was specified then a simple, unweighted average is used. +If the sum of the weights of for the accepted pixels is zero then the +unweighted average is output. + +.in -2 +MEDIAN +.in 2 +The median of the remaining pixels is computed. The median is the +usual mathematical definition where a particular pixel value is produced +for an odd number of pixels and the average of the two central values +is computed for an even number of pixels. + +.in -2 +SUM +.in 2 +The sum of the unrejected pixels is computed. + +.in -2 +LMEDIAN +.in 2 +The median of the remaining pixels is computed except that for two +pixels the lower value is used. This is a specialized feature useful +for minimizing the effects of cosmic rays in dithered and/or masked data. + +.in -2 +QUADRATURE +.in 2 +The pixels are combined as + +.nf + sqrt (sum {(wt * sigma)^2}) / sum {wt} +.fi + +This is used when the input pixel values represent "sigmas". This option +is usually a second pass after the input data has been combined. It is +important that the input is arranged such that the same scaling and +pixel rejections are used. This means that these cannot be given by +explicit lists and masks and not generated from the data. + +.in -2 +QUADRATURE +.in 2 +The pixels are combined as + +.nf + value = max (0, scaled_pixel_value) + variance = rdnoise^2 + value / gain + (snoise * value)^2 + output = sqrt (sum {variance * wt^2}) / sum {wt} +.fi + +This is used when the variances in the input images can be computed +by the above noise model. Note that the gain and rdnoise are adjusted +for any scaling applied to the pixel values. + +This method has the advantage that the input images are the same as +those used to form a combined image and so all the steps of deriving +scaling and rejecting pixels by some rejection method will be the same. +.in -4 + +SIGMA OUTPUT + +In addition to the combined image and optional sigma image may be +produced. The sigma computed is the standard deviation, corrected for a +finite population by a factor of n/(n-1), of the unrejected input pixel +values about the output combined pixel values. +.ih +EXAMPLES +1. To average and median images without any other features: + +.nf + cl> imcombine obj* avg combine=average reject=none + cl> imcombine obj* med combine=median reject=none +.fi + +2. To reject cosmic rays: + +.nf + cl> imcombine obs1,obs2 Obs reject=crreject rdnoise=5.1, gain=4.3 +.fi + +3. To make a grid for display purposes with 21 64x64 images: + +.nf + cl> imcombine @list grid offset="grid 5 65 5 65" +.fi + +4. To apply a mask image with good pixels marked with a zero value and +bad pixels marked with a value of one: + +.nf + cl> hedit ims* bpm badpix.pl add+ ver- + cl> imcombine ims* final combine=median masktype=goodval +.fi + +5. To scale image by the exposure time and then adjust for varying +sky brightness and make a weighted average: + +.nf + cl> imcombine obj* avsig combine=average reject=avsig \ + >>> scale=exp zero=mode weight=exp expname=exptime +.fi +.ih +REVISIONS +.ls IMCOMBINE V2.12 +A number of enhancements for dealing with large numbers of images were +made. Also the masktype option "!", where is a +user specified keyword, was added. + +The new parameters "headers", "bpmasks", "rejmasks", "nrejmasks", and +"expmasks" provide additional types of output. The old parameters +"rejmask" and "plfile" were removed. The new "nrejmasks" corresponds +to the old "plfile" and the new "rejmasks" corresponds to the old +"rejmask". + +There is a new "combine" type "sum" for summing instead of averaging the +final set of offset, scaled, and weighted pixels. + +there is a new parameter "outlimits" to allow output of a subregion of +the full output. This is useful for raster surveys with large numbers +of images. + +Additional keywords may appear in the output headers. + +The scaling is now done relative to the first image rather than an +average over the images. This is done so that flux related keywords +such as exposure time and airmass remain representative. +.le +.ls IMCOMBINE V2.11.2 +The grow algorithm was improved to give a 2D growing radius. + +An optional output mask file contains the identifications of which pixel +in which input image was rejected or excluded. + +The internal calculation type was changed to be the highest precedence +of the input and output types. Previously it was only the input types. +.le +.ls IMCOMBINE V2.11 +The limit of the number of images that may be combined has been removed. +If the number of images exceeds the maximum number of open images permitted +then the images are stacked in a single temporary image and then combined +with the project option. Note that this will double the amount of +diskspace temporarily. There is also a limitation in this case that the +bad pixel mask from the first image in the list will be applied to all the +images. + +Integer offsets may be determined from the image world coordinate system. + +A combination of ushort and short images now defaults to integer. +.le +.ls IMCOMBINE V2.14 +The "masktype" parameter has been generalized to allow both using a +different keyword for the input mask and choosing the mask method. +The "novalue" masktype is new and is useful for maintaining a distinction +between no data and possibly marginally useful or cosmetically useful +data. +.le +.ls IMCOMBINE V2.10.3 +The input scalings from an @file or header keyword are now truly +mulitplicative or additive and they are not normalized. The output +pixel types now include unsigned short integer. +.le +.ls IMCOMBINE V2.10.2 +The weighting was changed from using the square root of the exposure time +or image statistics to using the values directly. This corresponds +to variance weighting. Other options for specifying the scaling and +weighting factors were added; namely from a file or from a different +image header keyword. The \fInkeep\fR parameter was added to allow +controlling the maximum number of pixels to be rejected by the clipping +algorithms. The \fIsnoise\fR parameter was added to include a sensitivity +or scale noise component to the noise model. Errors will now delete +the output images. +.le +.ls IMCOMBINE V2.10 +This task was greatly revised to provide many new features. These features +are: + +.nf + o Bad pixel masks + o Combining offset and different size images + o Blank value for missing data + o Combining across the highest dimension (the project option) + o Separating threshold rejection, the rejection algorithms, + and the final combining statistic + o New CCDCLIP, CRREJECT, and PCLIP algorithms + o Rejection now may reject more than one pixel per output pixel + o Choice of a central median or average for clipping + o Choice of final combining operation + o Simultaneous multiplicative and zero point scaling +.fi +.le +.ih +LIMITATIONS +Though the previous limit on the number of images that can be combined +was removed in V2.11 the method has the limitation that only a single +bad pixel mask will be used for all images. +.ih +SEE ALSO +ccdred.combine mscred.combine onedspec.scombine, wpfc.noisemodel, +obsolete.ocombine +.endhelp diff --git a/pkg/images/immatch/doc/linmatch.hlp b/pkg/images/immatch/doc/linmatch.hlp new file mode 100644 index 00000000..21c04b22 --- /dev/null +++ b/pkg/images/immatch/doc/linmatch.hlp @@ -0,0 +1,699 @@ +.help linmatch Apr95 images.immatch +.ih +NAME +linmatch -- linearly match the intensity scales of 1 and 2D images +.ih +USAGE +linmatch input reference regions lintransform +.ih +PARAMETERS +.ls input +The list of input images to be matched. +.le +.ls reference +The list of reference images to which the input images are to be matched +if \fIscaling\fR is one of the "mean", "median", "mode", or "fit" +algorithms, or the list of reference photometry files if \fIscaling\fR +specifies the "photometry" algorithm. The number of reference images or +reference photometry files must be one or equal to the number of input +images. +.le +.ls regions +The list of image regions used to compute the intensity +matching function if \fIscaling\fR is one of the "mean", "median", "mode", +or "fit" algorithms, or a list of the input photometry files if +\fIscaling\fR specifies the "photometry" algorithm. In the former +case \fIregions\fR may be: 1) a string of the form "grid nx ny" defining +a grid of nx by ny equally spaced and sized image regions spanning the +entire image, 2) a list of object coordinates separated by commas e.g. +"303 401, 131 202", 3) a list of image sections separated by whitespace +e.g "[101:200,101:200] [301:400,301:400]", +4) the name of a text file containing a list of object coordinates separated +by newlines, and 5) the name of a text file containing a list of image +sections separated by whitespace and/or newlines. +.le +.ls lintransform +The name of the text file where the computed scaling factors are written. +If \fIdatabasefmt\fR is "yes", a single record containing the computed +bscale and bzero factors for each image region or object, and the +average bscale and bzero, is written to the text database +file for each input image. If \fIdatabasefmt\fR = "no", a single line +containing the input image name, bscale factor, bzero factor, error +in bscale, and error in bzero is written to a simple text file for +each image. +.le +.ls output = "" +The list of output matched images. If \fIoutput\fR is the NULL string +then bscale and bzero are computed for each input image and written to +\fIlintransform\fR, but no output images are written. If \fIoutput\fR +is not NULL then the number of output images must equal the number of +input images. +.le +.ls databasefmt = yes +If \fIdatabasefmt\fR is "yes" the computed bscale and bzero factors +are written to a text database file, otherwise they are written to a +simple text file. +.le +.ls records = "" +The list of records to be written to or read from \fIlintransform\fR one +input image. If \fIrecords\fR is NULL then the output or input record names +are assumed to be the names of the input images. If \fIrecords\fR is not NULL +then the record names in \fIrecords\fR are used to write / read the +database records. This parameter is useful for users +who, wish to compute the bscale and bzero factors using images that have +been processed +in some manner (e.g. smoothed), but apply the computed bscale and bzero +factors to the original unprocessed images. If more than one record +with the same name exists in \fIlintransform\fR then the most recently written +record takes precedence. The records parameter is ignored if +\fIdatabasefmt\fR is "no". +.le +.ls append = yes +Append new records to an existing \fIlintransform\fR file or start a new +file for each execution of LINMATCH? The append parameter is +ignored if \fIdatabasefmt\fR is "no". +.le +.ls shifts = "" +An optional list of shifts files containing the x and y shifts to be applied +to the reference regions to determine their positions in +the input images. The number of shifts files must equal the number of +reference images. The shifts are listed in the shifts file, 1 shift per line, +with the x and y shifts in +columns 1 and 2 respectively. If there are fewer x and y shifts defined +in the shifts file than there are input images, the extra input +images will be assigned x and y shifts of \fIxshift\fR and \fIyshift\fR +respectively. The shifts parameter is ignored if the \fIscaling\fR +parameter is set to "photometry". +.le +.ls xshift = 0.0 yshift = 0.0 +The default x and y shifts to be applied to the reference image regions +or objects to compute their positions in the input image. +Values in \fIshifts\fR take precedence over the values of \fIxshift\fR and +\fIyshift\fR. xshift and yshift are ignored if the \fIscaling\fR parameter +is set to "photometry". +.le +.ls dnx = 31 dny = 31 +The default size of a single image region used to compute the bscale +and bzero factors if \fIscaling\fR is one of the "mean", "median", "mode", +or "fit" algorithms and \fIregions\fR is a coordinate list rather than +a sections list. dnx and dny are ignored if the \fIscaling\fR parameter +is set to "photometry". +.le +.ls maxnregions = 100 +The maximum number of image regions or objects with measured photometry +that can be used to compute the bscale and bzero factors. +.le +.ls scaling = "mean mean" +The algorithms used to compute the bscale and bzero factors respectively. +The options are: +.ls mean median mode +Bscale or bzero are computed using the "mean", "median", or "mode" statistic +for each input and reference region individually. If one of the bscale or +bzero fitting +algorithms is set to "mean", "median", or "mode", the remaining factor +must be set to "mean", "median" or "mode" or a numerical constant, +e.g. "mean mean", "mean -100.0" or "2.63 mode". +If both algorithms are set to "mean", "median", or "mode" bscale will be +computed using the specified statistic and bzero will be set to 0.0 +If more than one input region is defined then a weighted least squares +fit of the reference statistics to the input image statistics +is performed and used to compute the final bscale and bzero factors. +.le +.ls fit +Bscale and bzero are computed for each input image region individually +by performing a least squares fit of the reference image pixels to +the input image pixels. If more than one input image region is defined +the final bscale and bzero factors are computed by averaging, +weighted by their signal-to-noise ratios, the individual bscale and bzero +values. If one of the bscale or bzero fitting +algorithms is set to "fit", the remaining factor must either also +be computed with the "fit" algorithm or set to a numerical constant, +e.g. "fit fit", "fit -100.0", or "2.63 fit". +.le +.ls photometry +Bscale and/or bzero are computed for each input object individually +using photometry computed for a set of objects common to the reference +and input images. If more than one input object is defined +the final bscale and bzero factors are computed by averaging, +weighted by their signal-to-noise ratios, the individual bscale and bzero +values. If one of the bscale or bzero fitting +algorithms is set to "photometry", the remaining factor must either also +be computed with the "photometry" algorithm or set to a numerical +constant, e.g. "photometry photometry", "photometry -100.0", or +"2.63 photometry". +.le +.ls number +Bscale and/or bzero are set to user defined numerical constants, +e.g. "2.62 -55.0" or "2.62 median". If both bscale and bzero are numerical +constants, LINMATCH must be run in non-interactive mode. If only one of bscale +or bzero is a numerical constant, any of the "mean", "median", "mode", "fit", +or "photometry" algorithms may be used to compute the remaining factor. +.le +.ls file +Bscale and bzero are not computed but instead read from record \fIrecord\fR in +the text database file \fIlintransform\fR if \fIdatabasefmt\fR is "yes", +or the next line of a simple text file if \fIdatabasefmt\fR is "no". +.le + +Further description of the matching algorithms can be found in the ALGORITHMS +section. +.le +.ls datamin = INDEF datamax = INDEF +The minimum and maximum good data values. Datamin and datamax are used by +the "mean", "median", and "mode" scaling algorithms to reject entire +image regions from the final fit, and by the "fit" algorithm to reject +individual bad pixels from the least squares fits for the individual +regions. +.le +.ls maxiter = 10 +The maximum number of iterations performed by the least squares fitting +algorithm. +.le +.ls nreject = 0 +The maximum number of rejection cycles used to detect and reject bad pixels +from the fit if the scaling algorithm is "fit" or bad regions / objects +from the fit if the scaling algorithm is "mean", "median", "mode", "fit", +or "photometry". +.le +.ls loreject = INDEF hireject = INDEF +The high- and low-side bad data rejection limits used to detect and reject +deviant pixels from the fit if the scaling algorithm is "fit" or bad +regions / objects from the fit if the scaling algorithm is "mean", "median", +"mode", "fit", or "photometry". +.le +.ls gain = "1.0 1.0" readnoise = "0.0 0.0" +The reference and input image gain and readout noise in e-/ADU and +e- respectively. Gain and readout may be numerical constants or the +image header keyword containing the actual gain and/or readout noise +value. Gain and readnoise are used by the "mean", "median", "mode", +and "fit" algorithms to estimate the expected errors in the computed +"mean", "median", or "mode" statistics, and by the "fit" algorithm +to compute the per pixel errors values. +.le +.ls interactive = no +Compute the bscale and bzero scaling factors for each image interactively +using graphics cursor and optionally image cursor input. +.le +.ls verbose = yes +Print messages about the progress of the task during task execution in +non-interactive mode. +.le +.ls graphics = "stdgraph" +The default graphics device. +.le +.ls display = "stdimage" +The default image display device. +.le +.ls gcommands = "" +The default graphics cursor. +.le +.ls icommands = "" +The default image cursor. +.le + +.ih +DESCRIPTION + +LINMATCH computes the bscale and bzero factors required to match +the intensity scales of a list of input +images \fIinput\fR to the intensity scales of a list of reference +images \fIreference\fR using the following definition of +bscale and bzero and a variety of techniques. + +.nf + reference = bscale * input + bzero +.fi + +The computed bscale and bzero factors are stored +in the text file \fIlintransform\fR, in the record \fIrecords\fR if +\fIdatabasefmt\fR is "yes", or a single line of a simple text file +if \fIdatabasefmt\fR is "no". One record is written to the output file +file for each input image. If a non NULL list of output images +\fIoutput\fR is supplied, a scaled output image is written for +each input image. LINMATCH is intended to solve 1D and 2D image intensity +matching problems where the input and reference images: 1) have the same +pixel scale and orientation, 2) differ in intensity by at most a scale +factor and a zero point, and 3) contain one or more regions or objects in +common that can be used to compute the scaling factors. Some of the scaling +algorithms also require that the images registered and have identical +point spread functions. LINMATCH cannot be used to compute or apply non-linear +intensity matching functions. + +If \fIscaling\fR = "mean", "median", "mode", or "fit" bscale and bzero +are computed directly from the input and reference image data using the +image sections specified in the \fIregions\fR and one of the above fitting +techniques as described in the ALGORITHMS section. All four algorithms +require accurate knowledge of the measurement errors which in turn +require accurate knowledge of the input and reference image gain and +readout noise values. Gain and readout noise values can be entered by +setting the \fIgain\fR and \fIreadnouse\fR parameters to the appropriate +numerical values or image header keyword. + +\fIRegions\fR is interpreted as either: 1) a string of +the form "grid nx ny" specifying a list of nx by ny image sections +spanning the entire image, 2) a string defining the coordinates of a list +of objects separated by commas e.g. +"103.3 189.2, 204.4 389.7", 3) a string containing a list of image +sections separated by whitespace, e.g "[100:203,200:300] [400:500,400:500]" +4) the name of a text file containing the coordinates of one or +more objects, one object per line, with the x and y coordinates +in columns 1 and 2 respectively, 5) the name of a text +file containing a list of image sections separated by whitespace and/or +newlines. The image sections specifications, or alternatively +the object coordinates and the parameters \fIdnx\fR and \fIdny\fR, +determine the size of the input and reference image data regions to be +extracted and used to compute the bscale and bzero factors. +These image regions should be selected with care. Ideal regions +span a range of intensity values and contain both object and background +data. + +If \fIscaling\fR = "photometry", the bscale and bzero factors +are computed directly from data in the input and reference image photometry +files using the technique described in the ALGORITHMS section. +In this case \fIregions\fR is a list of the input image photometry +files and \fIreference\fR are the corresponding reference image +photometry files written by a separate photometry task. +These photometry files are simple text files with the object +sky values, errors in the sky values, magnitudes, and errors in the +magnitudes in columns 1, 2, 3, and 4 respectively. + +An image region is rejected from the fit if it contains data outside the +limits specified by the \fIdatamin\fR and \fIdatamax\fR parameters +and \fIscaling\fR = +"mean", "median", or "mode". A pixel is rejected from the fit for an +individual region if the pixel value is outside the limits specified +by datamin and datamax, and the scaling algorithm is "fit". The datamin +and datamax parameters are not used by the "photometry" scaling algorithm . + +Deviant pixels can be rejected from the fits to individual image regions +if \fIscaling\fR = "fit", and \fInreject\fR, \fIloreject\fR, and +\fIhireject\fR are set appropriately. Nreject, loreject and reject +are also be used by all the scaling algorithms to reject image regions +which contribute deviant bscale and bzero values. + +The computed bscale and bzero value for each region and the final bscale +and bzero value for each input image are written to the linear +transformation file \fIlintransform\fR. +If \fIdatabasefmt\fR is "yes" each result is written to a record whose name +is either identical to the name of the input +image or supplied by the user via the \fIrecords\fR parameter . +If \fIdatabasefmt\fR is "no", then a single line containing the input image +name and the computed bscale and bzero values and their errors +is written to the output shifts file. + +If a list of output image names have been supplied then the bscale and +bzero values will be applied to the input images to compute the output images. + +If the \fIscaling\fR parameter is set to "file" then the shifts +computed in a previous run of LINMATCH will be read from the \fIlintransform\fR +file and applied to the input images to compute the output images. +If no record list is supplied by the user LINMATCH will +search for a record whose name is the same as the input image name. If more than +one record of the same name is found then the most recently written +record will be used. + +In non-interactive mode the task parameters are set at task startup time +and the input images are processed sequentially. If the \fIverbose\fR +flag is set, messages about the progress of the task are printed on the +screen as the task is running. + +In interactive mode the user can mark the regions to be used +to compute the matching function on the image display, show/set the data +and algorithm parameters, compute, recompute, and plot +matching function, and interactively delete and undelete +bad data from the fits using the plots and graphics cursor. A summary +of the available interactive commands is given in the CURSOR COMMANDS +section. + +.ih +CURSOR COMMANDS + +.nf +The following graphics cursor commands are currently available in LINMATCH. + + Interactive Keystroke Commands + +? Print help +: Colon commands + +g Draw a plot of the current fit +i Draw the residuals plot for the current fit +p Draw a plot of current photometry +s Draw histograms for the image region nearest the cursor +l Draw the least squares fit for the image region nearest the cursor +h Draw histogram plot of each image region in turn +l Draw least squares fits plot of each image region in turn +r Redraw the current plot +d Delete the image region nearest the cursor +u Undelete the image region nearest the cursor +f Recompute the intensity matching function +w Update the task parameters +q Exit + + + Colon Commands + +:markcoords Mark objects on the display +:marksections Mark image sections on the display +:show Show current values of all the parameters + + Show/set Parameters + +:input [string] Show/set the current input image +:reference [string] Show/set the current reference image / phot file +:regions [string] Show/set the current image regions +:photfile [string] Show/set the current input photometry file +:lintransform [string] Show/set the linear transform database file name +:dnx [value] Show/set the default x size of an image region +:dny [value] Show/set the default y size of an image region +:shifts [string] Show/set the current shifts file +:xshift [value] Show/set the input image x shift +:yshift [value] Show/set the input image y shift +:output [string] Show/set the current output image name +:maxnregions Show the maximum number of objects / regions +:gain [string] Show/set the gain value / image header keyword +:readnoise [string] Show/set the readout noise value / image header + keyword + +:scaling Show the current scaling algorithm +:datamin [value] Show/set the minimum good data value +:datamax [value] Show/set the maximum good data value +:nreject [value] Show/set the maximum number of rejection cycles +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +.fi + +.ih +ALGORITHMS + +MEAN, MEDIAN, AND MODE + +For each input and reference image region the mean, median, mode, statistic +and an error estimate for that statistic are computed as shown below, +mstat is for mean, median, or mode statistic, emstat stands for the error +estimate, stdev for the measured standard deviation, and npix for the +number of points. + +.nf + mstat = mean, median, or mode + emstat = min (sqrt (mean / gain + readnoise ** 2 / gain ** 2), + stdev / sqrt(npix)) +.fi + +If only a single image region is specified then mstat is used to compute +one of bscale or bzero but not both as shown below. Bscale is computed by +default. + +.nf + bscale = mstat[ref] / mstat[input] + err[bscale] = abs (bscale) * sqrt (emstat[ref] ** 2 / mstat[ref] ** 2 + + emstat[input] ** 2 / mstat[input] ** 2) + bzero = constant + err[bzero] = 0.0 + + bzero = mstat[ref] - mstat[input] + err[bzero] = sqrt (emstat[ref] ** 2 + emstat[input] ** 2) + bscale = constant + err[bscale] = 0.0 +.fi + +If more than one image region is defined then the computed mean, median, +or mode values for the input and reference image regions are used as +shown below to compute the bscale and bzero factors and their errors +using a weighted least squares fit. + +.nf + mstat[ref] = bscale * mstat[input] + bzero +.fi + +If an image region contains data outside the limits defined +by \fIdatamin\fR and \fIdatamax\fR that image region is eliminated +entirely from the fit. + +The parameters \fInreject\fR, \fIloreject\fR, +and \fIhireject\fR are used to detect and automatically eliminate +deviant data points from the final least squares fit. If for some reason +bscale or bzero cannot be fit, default values of 1.0 and 0.0 are +assigned. + +The mean, median, and mode algorithms depend on the global properties of +the image regions. These algorithms do require the reference and +input images to have the same pixel scale and orientation, +but do not automatically require the reference and input images +to have the same point spread function. Small shifts between the reference +and input images can be removed using the \fIshifts\fR, \fIxshift\fR, and +\fIyshift\fR parameters. + +If the image regions contain stars, then either regions should be large +enough to include all the flux of the stars in which case the images +do not have to have the same psf, or the psfs should be the same so +that same portion of the psf is sampled. The best image regions for +matching will contain object and background information. + +FIT + +For each input and reference image the bscale and bzero factors are +computed by doing a pixel to pixel weighted least squares fit of the reference +image counts to the input image counts as shown below. + +.nf + counts[ref] = bscale * counts[input] + bzero + weight = 1.0 / (err[ref] ** 2 + bscale ** 2 * err[input] ** 2) + err[ref] = sqrt (counts[ref] / gain[ref] + readnoise[ref] ** 2 / + gain[ref] ** 2) + err[input] = sqrt (counts[input] / gain[input] + + readnoise[input] ** 2 / gain[input] ** 2) +.fi + +The fitting technique takes into account errors in both the reference and +input image counts and provides an error estimate for the computed bscale +and bzero factors. Bad data are rejected +automatically from the fit by setting the \fIdatamin\fR and \fIdatamax\fR +parameters. Deviant pixels are rejected from the fit by setting the +\fInreject\fR, \fIloreject\fR, and \fIhireject\fR parameters appropriately. + +The final bscale and bzero for the input image are computed by calculating +the average weighted by their errors of the individual bscale and bzero +values. The parameters \fInreject\fR, \fIloreject\fR, and \fIhirject\fR +can be used to automatically detect and reject deviant points. + +The fit algorithm depends on the results of pixel to pixel fits in +each reference and input image region. The technique requires that the +images be spatially registered and psfmatched before it is employed. +Each input and reference image should contain a range of pixel intensities +so that both bscale and bzero can be accurately determined. + +PHOTOMETRY + +For each object common to the reference and input photometry files +the input sky values sky, errors in the sky values serr, +magnitudes mag, and magnitude errors merr are used to compute the +bscale and bzero factors and estimate their errors as shown +below. + +.nf + bscale = 10.0 ** ((mag[ref] - mag[input]) / 2.5) + bzero = sky[ref] - bscale * sky[input] + err[bscale] = 0.4 * log(10.0) * bscale * sqrt (merr[ref] ** 2 + + magerr[input] ** 2)) + err[bzero] = sqrt (serr[ref] ** 2 + err[bscale] ** 2 * + sky[input] ** 2 + bscale ** 2 * sky[input] ** 2) +.fi + +The final bscale and bzero for the input image are computed by calculation +the average of the individual bscale and bzero values weighted by their +errors. The parameters \fInreject\fR, \fIloreject\fR, and \fIhirject\fR can +be used to automatically detect and reject deviant points. + +THE LEAST SQUARES FITTING TECHNIQUE + +The least squares fitting code performs a double linear regression on +the x and y points, taking into account the errors in both x and y. + +The best fitting line is the defined below. + +.nf + y = a * x + b +.fi + +The error ellipses are + +.nf + S = (x - xfit) ** 2 / err[x] ** 2 + (y - yfit) ** 2 / + err[y] ** 2 +.fi + +where S is the quantity to be minimized. Initial values of a and b are +estimated by fitting the data to a straight line assuming uniform +weighting. The best fit values of a and b are then +determined by iterating on the relationship + +.nf + dy = x' * da + db +.fi + +where da and db are corrections to the previously determined values of a and +b and dy and x' are defined as. + +.nf + dy = y - (ax + b) + x' = x + a * err[x] ** 2 * dy / (a ** 2 * err[x] ** 2 + + err[y] ** 2) +.fi + +The new values of the a and b then become. + +.nf + a = a + da + b = b + db +.fi + +.ih +REFERENCES + +A review of doubly weighted linear regression problems in +astronomy can be found in the paper "Linear Regression in Astronomy. II" +by (Feigelson and Babu (1992 Ap.J. 397, 55). A detailed derivation of the +particular solution used by LINMATCH can be found in the article +"The Techniques of Least Squares and Stellar Photometry with CCDs" +by Stetson (1989 Proceeding of the V Advanced School of Astrophysics, +p 51). + +.ih +EXAMPLES + +1. Match the intensity scales of a list of images to a reference +image using a list of stars on the displayed reference image with +the image cursor and the "mean" scaling algorithm. Assume that none +of the stars are saturated and that a radius of 31 pixels is sufficient +to include all the flux from the stars plus some background flux. +Make sure that the correct gain and readout noise values are in the +image headers. + +.nf + cl> display refimage 1 + + cl> rimcursor > objlist + ... mark several candidate stars by moving the cursor to the + star of interest and hitting the space bar key + ... type EOF to terminate the list + + cl> linmatch @imlist refimage objlist lintran.db \ + out=@outlist dnx=31 dny=31 scaling="mean mean" gain=gain \ + readnoise=readnoise +.fi + +2. Repeat the previous command but force the bzero factor to be -100.0 +instead of using the fitted value. + +.nf + cl> linmatch @imlist refimage objlist lintran.db \ + out=@outlist dnx=31 dny=31 scaling="mean -100.0" \ + gain=gain readnoise=rdnoise +.fi + +3. Repeat the first example but compute bscale and bzero +the bscale and bzero values using boxcar smoothed versions of +the input images. Make sure the gain and readout noise are +adjusted appropriately. + +.nf + cl> linmatch @bimlist brefimage objlist lintran.db \ + dnx=31 dny=31 scaling="mean mean" gain=gain \ + readnoise=rdnoise + + cl> linmatch @imlist refimage objlist lintran.db \ + out=@outimlist records=@bimlist scaling="file file" +.fi + +4. Match the intensity of an input image which has been spatially +registered and psfmatched to the reference image using the "fit" algorithm +and a single reference image region. Remove the effects of saturated +pixels by setting datamax to 28000 counts, and the effects of any deviant pixels +by setting nreject, loreject, and hireject to appropriate values. + +.nf + cl> linmatch image refimage [50:150,50:150] lintran.db \ + out=outimage scaling="fit fit" datamax=28000 nreject=3 \ + loreject=3 hireject=3 gain=gain readnoise=rdnoise +.fi + +5. Repeat the previous example but use several image sections to compute +the bscale and bzero values. + +.nf + cl> linmatch image refimage sections lintran.db \ + out=outimage scaling="fit fit" datamax=28000 nreject=3 \ + loreject=3 hireject=3 gain=gain readnoise=rdnoise +.fi + +6. Match the intensity scales of two images using photometry +computed with the apphot package qphot task. The two images are +spatially registered, psfmatched, and the photometry aperture is sufficient to +include all the light from the stars. The filecalc task used to compute +the error in the mean sky is in the addon ctio package. + +.nf + cl> display refimage 1 fi+ + cl> rimcursor > objlist + ... mark several candidate stars by moving the cursor to the + star of interest and hitting the space bar key + ... type EOF to terminate the list + cl> qphot refimage coords=objlist inter- + cl> qphot image coords=objlist inter- + cl> pdump refimage.mag.1 msky,stdev,nsky,mag,merr yes | filecalc \ + STDIN "$1;$2/sqrt($3);$4;$5" > refimage.phot + cl> pdump image.mag.1 msky,stdev,nsky,mag,merr yes | filecalc \ + STDIN "$1;$2/sqrt($3);$4;$5" > image.phot + cl> linmatch image refimage.phot image.phot lintran.db \ + out=outimage scaling="phot phot" nreject=3 loreject=3\ + hireject=3 +.fi + +7. Register two images interactively using the fit algorithms and +five non-overlapping image regions in the sections file. + +.nf + cl> linmatch image refimage sections lintran.db \ + out=outimage scaling="fit fit" datamax=28000 nreject=3 \ + loreject=3 hireject=3 gain=gain readnoise=rdnoise \ + interactive + + + ... a plot of bscale and bzero versus region number + appears + + ... type ? to get a list of the keystroke and : commands + + ... type i to see a plot of the bscale and bzero residuals + versus region + + ... type g to return to the default bscale and bzero versus + region plot + + ... type l to examine plot of the fits and residuals for the + individual regions + ... step forward and back in the regions list with the + space bar and -keys + ... flip back and forth between the fit and residuals + keys with l and i keys + ... return to the main plot by typing q + + ... return to the residuals plot by typing i and delete a + region with a large residual by moving to the + bad point and typing d + + ... type f to recompute the fit + + ... type q to quit the interactive loop, n to go to the + next image or q to quit the task + +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imexpr, imcombine, ctio.filecalc, apphot.qphot, apphot.phot +.endhelp diff --git a/pkg/images/immatch/doc/psfmatch.hlp b/pkg/images/immatch/doc/psfmatch.hlp new file mode 100644 index 00000000..4972700e --- /dev/null +++ b/pkg/images/immatch/doc/psfmatch.hlp @@ -0,0 +1,595 @@ +.help psfmatch Oct94 images.immatch +.ih +NAME +psfmatch -- match the point spread functions of 1 and 2D images +.ih +USAGE +psfmatch input reference psfdata kernel +.ih +PARAMETERS +.ls input +The list of input images to be matched. +.le +.ls reference +The list of reference images to which the input images are to be matched if +\fIconvolution\fR = "image", or the list of reference image psfs if +\fIconvolution\fR = "psf". The reference image psf must be broader than the +input image psf in at least one dimension. +The number of reference images/psfs must be one or equal to the number of +input images. +.le +.ls psfdata +The list of objects used to compute the psf matching function if +\fIconvolution\fR is "image", or the list of input image psfs if +\fIconvolution\fR is "psf". In the former case \fIpsfdata\fR may be: +1) a string containing the x and y coordinates of a single object, +e.g. "51.0 105.0" or 2) the name of a text file containing a list of +objects, and the number of objects +files must equal the number of reference images. In the latter case +the number of input psf images must equal the number of input images. +.le +.ls kernel +The list of input/output psf matching function images to be convolved with the +input images to produce the output images. The number of kernel images +must equal the number of input images. +.le +.ls output = "" +The list of output matched images. If \fIoutput\fR is the NULL string +then the psf matching function is computed for each input image and written to +\fIkernel\fR but no output images are written. If \fIoutput\fR is not NULL +then the number of output images must equal the number of input images. +.le +.ls convolution = "image" +The algorithm used to compute the psf matching function. The options are: +.ls image +The psf matching function is computed directly from the reference and input +image data using the objects specified in \fIpsfdata\fR, the data +regions specified by \fIdnx\fR, \fIdny\fR, \fIpnx\fR, and \fIpny\fR, +and the convolution theorem. +.le +.ls psf +The psf matching function is computed directly from pre-computed +reference and input image psfs using the convolution theorem. +.le +.ls kernel +No psf matching function is computed. Instead the psf matching function +is read from the input image \fIkernel\fR. +.le +.le +.ls dnx = 31, ls dny = 31 +The x and y width of the data region to be extracted around each object. The +data region should be big enough to include both object and sky data. +\fIDnx\fR and \fIdny\fR are not used if \fIconvolution\fR is "psf" or +"kernel". +.le +.ls pnx = 15, pny = 15 +The x and y width of the psf matching function to be computed which must be +less than \fIdnx\fR and \fIdny\fR respectively. The psf +matching function should be kept as small as possible to minimize +the time required to compute the output image. +\fIPnx\fR and \fIPny\fR are not used if \fIconvolution\fR is "psf" or +"kernel". +.le +.ls center = yes +Center the objects in \fIpsfdata\fR before extracting the data from the +input and reference images. Centering should be turned off if the objects +are non-stellar and do not have well-defined centers. +Centering is turned off if \fIconvolution\fR is "psf" or +"kernel". +.le +.ls background = median +The default background function to be subtracted from the input +and reference image data in each object region before the +psf matching function is computed. The background is computed using +data inside the data extraction region defined by \fIdnx\fR and \fIdny\fR +but outside the kernel region defined by \fIpnx\fR and \fIpny\fR. +Background fitting is turned off if \fIconvolution\fR is "psf" or +"kernel". +The options are: +.ls none +no background subtraction is done. +.le +.ls "insky refsky" +the numerical values of insky and refsky are subtracted from the +input and reference image respectively. +.le +.ls mean +the mean of the input and reference image region is computed and subtracted +from the image data. +.le +.ls median +the median of the input and reference image region is computed and subtracted +from the data. +.le +.ls plane +a plane is fit to the input and reference image region and subtracted +from the data. +.le +.le +.ls loreject = INDEF, ls hireject = INDEF +The k-sigma rejection limits for removing the effects of bad data from the +background fit. +.le +.ls apodize = 0.0 +The fraction of the input and reference image data endpoints in x and y +to apodize with a +cosine bell function before the psf matching function is computed. +Apodizing is turned off if \fIconvolution\fR is "psf" or +"kernel". +.le +.ls fluxratio = INDEF +The ratio of the integrated flux of the reference objects to the integrated +flux of the input objects. +By default \fIfluxratio\fR is computed directly from the input data. +.le +.ls filter = "replace" +The filter used to remove high frequency noise from the psf +matching function. Filtering is not performed if \fIconvolution\fR +is "kernel". The options are: +.ls cosbell +apply a cosine bell taper to the psf matching function in frequency space. +.le +.ls replace +replace the high-frequency low signal-to-noise components of the psf matching +function with a gaussian model computed from the low frequency +high signal-to-noise components of the matching function. +.le +.ls model +replace the entire psf matching function with a gaussian model fit to the +low frequency high signal-to-noise components of the matching function. +.le +.le +.ls sx1 = INDEF, sx2 = INDEF, sy1 = INDEF, sy2 = INDEF +The limits of the cosine bell taper in frequency space. Frequency components +inside sx1 and sy1 are unaltered. Frequency components outside sx2 and sy2 +are set to 0.0. By default sx1 and sy1 are set to 0.0, +and sx2 and sy2 are set to the largest frequency present in the data. +.le +.ls radsym = no +Compute a radially symmetric cosine bell function ? +.le +.ls threshold = 0.2 +The low frequency cutoff in fraction of the total input image spectrum +power for the filtering options "replace" and "model". +.le +.ls normfactor = 1.0 +The total power in the computed psf matching function \fIkernel\fR. By default +the psf matching function is normalized. If \fInormfactor\fR +is set to INDEF, then the total power is set to \fIfluxratio\fR. +\fINormfactor\fR is not used if \fIconvolution\fR is set "kernel". +.le +.ls boundary_type = "nearest" +The boundary extension algorithm used to compute the output matched +image. The options are: +.ls nearest +use the value of the nearest boundary pixel. +.le +.ls constant +use a constant value. +.le +.ls reflect +generate a value by reflecting about the boundary. +.le +.ls wrap +generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0.0 +The default constant for constant boundary extension. +.le +.ls interactive = no +Compute the psf matching function for each image +interactively using graphics cursor and, optionally, image cursor input. +.le +.ls verbose +Print messages about the progress of the task in non-interactive mode. +.le +.ls graphics = "stdgraph" +The default graphics device. +.le +.ls display = "stdimage" +The default image display device. +.le +.ls gcommands = "" +The default graphics cursor. +.le +.ls icommands = "" +The default image display cursor. +.le + +.ih +DESCRIPTION + +PSFMATCH computes the convolution kernel required to match the +point-spread functions +of the input images \fIinput\fR to the point-spread functions of +the reference images \fIreference\fR using either the image data +or pre-computed psfs and the convolution theorem. +The computed psf matching functions are stored in the \fIkernel\fR images. +If a non-NULL list of output images \fIoutput\fR is +specified the input images are +convolved with the kernel images to produce a list of psf matched output +images. PSFMATCH requires +that the input and reference images be spatially registered +and that the reference images have poorer resolution (broader PSF) +than the input images in at least one dimension. + +If \fIconvolution\fR = "image", the matching function is computed directly +from the input and reference image data using the objects listed in +\fIpsfdata\fR and the convolution theorem as described in the ALGORITHMS +section. \fIpsfdata\fR is interpreted as either: 1) a +string defining the coordinates of a single object e.g. "103.3 189.2" or 2) +the name of a text file containing the coordinates of one or +more objects, one object per line, with the x and y coordinates +in columns 1 and 2 respectively. The object coordinates, the +size of the data region to be extracted \fIdnx\fR +by \fIdny\fR, and the size of the kernel to be computed \fIpnx\fR and +\fIpny\fR, determine +the input and reference image regions used to compute the psf matching +function. +These image regions should be selected with care. Ideal regions +contain a single high signal-to-noise unsaturated star which has no close +neighbors and is well centered on a pixel. + +If \fIcenter\fR is "yes" and \fIconvolution\fR is "image", the objects +in \fIpsfdata\fR are centered before +the data region is extracted. Centering should be on if the objects +are stellar, particularly if their coordinates were read from the image +display cursor. Centering should be off if the objects are non-stellar and +do not have well-defined centers. + +If the \fIbackground\fR fitting algorithm is other than "none" and +\fIconvolution\fR is "image", the background for each object is fit using +data inside the region defined by +\fIdnx\fR and \fIdny\fR but outside the region defined by +\fIpnx\fR by \fIpny\fR. Bad data can be removed from the +background fit by setting the parameters \fIloreject\fR and \fIhireject\fR. +A cosine bell function is applied to the edges of the data region +after background fitting but before computing the psf matching function +if the \fIapodize\fR parameter is > 0.0. + +If \fIpsfdata\fR contains more than one object, the extracted image data +is weighted by the total intensity in the extracted region after +background subtraction, and averaged to produce a single smoothed +data region for each reference and input image. + +If \fIconvolution\fR = "psf", +the psf matching function is computed directly from the input image +and reference +image point-spread functions +using the convolution theorem as described in the ALGORITHMS section. +In this case \fIpsfdata\fR is the list of input image psfs and +\fIreference\fR are the corresponding reference image psfs written by +by some external psf modeling task. +If \fIconvolution\fR is "psf", +centering and background fitting +are assumed to have been performed by the psf modeling task and are not +performed by PSFMATCH. + +PSFMATCH requires that the total power in the psf matching function +before normalization be the ratio +of the integrated flux of the reference image/psf over the integrated +flux of the input image/psf. If \fIfluxratio\fR is INDEF, PSFMATCH +estimates this number internally as described in the ALGORITHMS section, +otherwise the \fIfluxratio\fR is set to the value supplied by the user. + +If \fIconvolution\fR is "kernel", PSFMATCH reads the psf matching function +from the images in \fIkernel\fR which were either +created during a previous run of PSFMATCH or by a separate task. + +PSFMATCH provides several options for filtering out the ill-behaved +noise-dominated high frequency components of the psf matching function +that are produced when the ratio of reference / input image of psf +fourier transforms is taken. + +If \fIfilter\fR is set to "cosbell", a cosine bell function +with a taper defined by \fIsx1\fR, \fIsx2\fR, \fIsy1\fR, and \fIsy2\fR and +symmetry defined by \fRradsym\fR is applied to +the psf matching function in frequency space. This filter +sets all the frequency components greater than \fIsx2\fR and \fIsy2\fR +to 0.0 and leaves all frequency components inside \fIsx1\fR and \fIsy1\fR +unaltered. Users should exercise this option with caution as the effect +of the filtering process can be to significantly +broaden the computed psf matching function as described in the ALGORITHMS +section. + +An alternative approach to dealing with the noisy +high frequency components of the psf +matching function it is to replace them with a reasonable guess. If the +matching function is approximately gaussian then its fourier transform is also +approximately gaussian and the low frequency components can be modeled +reliably with an elliptical gaussian function. The model derived from the low +frequency components of the matching can then be used to replace the high +frequency components. +If \fIfilter\fR is set to "replace", those high frequency components +of the matching function which have less than a fraction +\fIthreshold\fR of their total power in the equivalent high frequency +components of the divisor or input image transform, +are replaced by a model computed by fitting a gaussian to the low frequency +components of the matching function, as described in the ALGORITHMS section. +If \fIfilter\fR = "model" then the entire psf matching function +is replaced with the best fitting gaussian model. + +Another problem can arise during the computation of the psf matching +function . Occasionally it is not possible by means of a single execution +of PSFMATCH to match the reference and input image psfs. An example +of this situation +is the case where the seeing of the reference and input images +was comparable but the declination guiding error in the reference +image was larger than the error in the input image. +In this case input image needs to be convolved to the resolution of +the reference image. However it is also the case +that the guiding error in ra in the input image is greater than the guiding +error in ra in the reference image. In this case the reference image needs +to be convolved to the resolution of the input image along the other axis. +If no corrective action is taken by the task, the +first time PSFMATCH is run the values of the psf matching function along +the ra axis will be greater than the computed fluxratio, resulting in +unrealistic action +along this axis. PSFMATCH avoids this situation by internally limiting +the psf matching function to a maximum value of fluxratio computed as described +above. + +By default the psf matching function is normalized to unit power before +output. This may not be what is desired since if carefully computed the +internally computed quantity a contains information about differences +in exposure time, transparency, etc. If \fInormfactor\fR is set to +a number of INDEF, the total power of the psf matching function will be +set to that value of \fIfluxratio\fR respectively. + +If a list of output images names has been supplied then the computed +psf matching function is applied to the input images to produce +the output images using the boundary extension algorithm +defined by \fIboundary\fR and \fIconstant\fR. + +In non-interactive mode the parameters are set at task startup time and +the input images are processed sequentially. If the \fIverbose\fR flag +is set messages about the progress of the task are printed on he +screen as the task is running. + +In interactive mode the user can mark the regions to be used to compute +the psf matching function on the image display, show/set the data +and algorithm parameters, compute, recompute, and plot the psf matching +function and its accompanying fourier spectrum, and experiment with the +various filtering and modeling options. + +.ih +CURSOR COMMANDS + +The following graphics cursor commands are currently available in +PSFMATCH. + +.nf + Interactive Keystroke Commands + + +? Print help +: Colon commands +k Draw a contour plot of the psf matching kernel +p Draw a contour plot of the psf matching kernel fourier spectrum +x Draw a column plot of the psf matching kernel / fourier spectrum +y Draw a line plot of the psf matching kernel / fourier spectrum +r Redraw the current plot +f Recompute the psf matching kernel +w Update the task parameters +q Exit + + + Colon Commands + + +:mark [file] Mark objects on the display +:show Show current values of the parameters + + + Show/Set Parameters + + +:input [string] Show/set the current input image name +:reference [string] Show/set the current reference image/psf name +:psf [file/string] Show/set the objects/input psf list +:psfimage [string] Show/set the current input psf name +:kernel [string] Show/set the current psf matching kernel name +:output [string] Show/set the current output image name + +:dnx [value] Show/set x width of data region(s) to extract +:dny [value] Show/set y width of data region(s) to extract +:pnx [value] Show/set x width of psf matching kernel +:pny [value] Show/set y width of psf matching kernel +:center [yes/no] Show/set the centering switch +:background [string] Show/set the background fitting function +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +:apodize [value] Show/set percent of endpoints to apodize + +:filter [string] Show/set the filtering algorithm +:fluxratio [value] Show/set the reference/input psf flux ratio +:sx1 [value] Show/set inner x frequency for cosbell filter +:sx2 [value] Show/set outer x frequency for cosbell filter +:sy1 [value] Show/set inner y frequency for cosbell filter +:sy2 [value] Show/set outer y frequency for cosbell filter +:radsym [yes/no] Show/set radial symmetry for cosbell filter +:threshold [value] Show/set %threshold for replace/modeling filter +:normfactor [value] Show/set the kernel normalization factor +.fi + +.ih +ALGORITHMS + +The problem of computing the psf matching function can expressed +via the convolution theorem as shown below. +In the following expressions r is the reference +image data or reference image psf, i is the input image data or input image +psf, k is the unit power psf matching +function, +a is a scale factor specifying the ratio of the total +power in the reference data or psf to the total power in the input data or +psf, * is the convolution operator, and FT is the fourier transform operator. + +.nf + r = ak * d + R = FT (r) + I = FT (i) + aK = R / I + ak = FT (aK) +.fi + +The quantity ak is the desired psf matching function and aK is its fourier +transform. + +If the background was accurately removed from the image or psf data before the +psf matching function was computed, the quantity a is simply the central +frequency component of the computed psf matching function aK as shown below. + +.nf + aK[0,0] = a = sum(r) / sum(i) +.fi + +If the background was not removed from the image or psf data before the +psf matching function was computed the previous expression is not valid. +The computed aK[0,0] will include an offset and a must be estimated +in some other manner. The approach taken by PSFMATCH in this circumstance +is to fit a gaussian model to the absolute value of 1st and 2nd frequencies +of R and I along the x and y axes independently, average the fitted x and y +amplitudes, and set aK[0,0] to the ratio of the resulting fitted amplitudes +as shown below. + +.nf + a = amplitude (R) / amplitude (I) + = (sum(r) - sum(skyr)) / (sum(i) - sum(skyi)) + aK[0,0] = a +.fi + +This approach will work well as long as the image data or psf is reasonably +gaussian but may not work well in arbitrary image regions. If the user is +dissatisfied with either of the techniques described above they can +set aK[0,0] to a pre-determined value of their own. + +If a filter is applied to the computed psf matching function in frequency +space then instead of computing + +.nf + ak = FT (aK) +.fi + +PSFMATCH actually computes + +.nf + ak' = FT (aKF) = ak * f +.fi + +where F is the applied filter in frequency space and f is its +fourier transform. Care should be taken in applying any filter. +For example if F is the step function, then ak' will be the desired kernel +ak convolved with f, a sinc function of frequency 2 * PI / hwidth where +hwidth is the half-width of the step function, and the resulting k' +will be too broad. + +If the user chooses to replace the high frequency components of the psf +matching function with a best guess, PSFMATCH performs the following +steps: + +.nf +1) fits an elliptical gaussian to those frequency components of the fourier +spectrum of aK for which for which the amplitude of I is greater +than threshold * I[0,0] to determine the geometry of the ellipse + +2) uses the fourier shift theorem to preserve the phase information in the +model and solve for any x and y shifts + +3) replace those frequency components of aK for which the fourier spectrum +of I is less than threshold * I[0,0] with the model values + + or alternatively + +replace all of aK with the model values +.fi + +.ih +EXAMPLES + +1. Psf match a list of input images taken at different epochs with variable +seeing conditions to a reference image with the poorest seeing by marking +several high signal-to-noise isolated stars on the displayed reference image +and computing the psf matching function directly from the input and reference +image data. User makes two runs with psfmatch one to compute and check the +kernel images and one to match the images. + +.nf + cl> display refimage 1 fi+ + + cl> rimcursor > objects + + cl> psfmatch @inimlist refimage objects @kernels dnx=31 \ + dny=31 pnx=15 pny=15 + + cl> imstat @kernels + + cl> psfmatch @inlist refimage objects @kernels \ + output=@outlist convolution="kernel" +.fi + +2. Psf match two spectra using a high signal-to-noise portion of the +data in the middle of the spectrum. Since the spectra are registered +spatially and there is little data available for background fitting the +user chooses to turn centering off and set the backgrounds manually. + +.nf + cl> psfmatch inspec refspec "303.0 1.0" kernel \ + output=outspec dnx=31 dny=31 pnx=15 pny=15 center- \ + back="403.6 452.0" +.fi + +3. Psf match two images using psf functions inpsf and refpsf computed with +the daophot package phot/psf/seepsf tasks. Since the kernel is fairly +large use the stsdas fourier package task fconvolve to do the actual +convolution. The boundary extension algorithm in fconvolve is equivalent +to setting the psfmatch boundary extension parameters boundary and +constant to "constant" and "0.0" respectively. + +.nf + cl> psfmatch inimage refpsf inpsf kernel convolution=psf + + cl> fconvolve inimage kernel outimage +.fi + +4. Psf match two images interactively using the image data itself to +compute the psf matching function. + +.nf + cl> psfmatch inimage refimage objects kernel interactive+ + + ... a contour plot of the psf matching function appears + with the graphics cursor ready to accept commands + + ... type x and y to get line and column plots of the psf + matching function at various points and k to return + to the default contour plot + + ... type ? to get a list of the available commands + + ... type :mark to define a new set of objects + + ... type f to recompute the psf matching function using + the new objects + + ... increase the data window to 63 pixels in x and y + with the :dnx 63 and :dny 63 commands, at the + same time increase the psf function size to 31 with + the colon commands :pnx 31 and :pny 31 + + ... type f to recompute the psf matching function using + the new data and kernel windows + + ... type q to quit the task, and q again to verify the previous + q command +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +convolve, gauss, stsdas.fconvolve, digiphot.daophot.psf +.endhelp diff --git a/pkg/images/immatch/doc/skymap.hlp b/pkg/images/immatch/doc/skymap.hlp new file mode 100644 index 00000000..b1a4a3fc --- /dev/null +++ b/pkg/images/immatch/doc/skymap.hlp @@ -0,0 +1,642 @@ +.help skymap Dec96 images.immatch +.ih +NAME +skymap -- compute the spatial transformation function required to register +a list of images using celestial coordinate WCS information +.ih +USAGE +skymap input reference database +.ih +PARAMETERS +.ls input +The list of input images containing the input celestial coordinate wcs. +.le +.ls reference +The list of reference images containing the reference celestial coordinate +wcs. The number of reference images must be one or equal to the number +of input images. +.le +.ls database +The name of the output text database file containing the computed +transformations. +.le +.ls transforms = "" +An option transform name list. If transforms is undefined then the +transforms are assigned record names equal to the input image names. +.le +.ls results = "" +Optional output files containing a summary of the results including a +description of the transform geometry and a listing of the input coordinates, +the fitted coordinates, and the fit residuals. The number of results files +must be one or equal to the number of input files. If results is "STDOUT" the +results summary is printed on the standard output. +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to generate +the grid of reference image control points and define the region of +validity of the spatial transformation. Xmin, xmax, ymin, and +ymax are assigned defaults of 1, the number of columns in the reference +image, 1, and the number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid. +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in degrees for all celestial coordinate +systems. Obviously if the +wcs is correct the ra and dec of an object +should remain the same no matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +.le +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls rwxformat = "", rwyformat = "" +The format of the output reference image celestial coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for all celestial coordinate +systems. +.le +.ls wxformat = "", wyformat = "" +The format of the output input image celestial coordinates +in columns 7 and 8 respectively. The internal default formats will give +reasonable output formats and precision for all celestial coordinate +systems. +.le +.ls fitgeometry = "general" +The fitting geometry to be used. The options are the following. +.ls shift +X and y shifts only are fit. +.le +.ls xyscale +X and y shifts and x and y magnification factors are fit. Axis flips are +allowed for. +.le +.ls rotate +X and y shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +X and y shifts, a magnification factor assumed to be the same in x and y, and a +rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +X and y shifts, x and y magnifications factors, and a rotation angle are fit. +Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes an x and y +shift, an x and y scale factor, a rotation and a skew. Axis flips are also +allowed for in the linear portion of the fit. The distortion term consists +of a polynomial fit to the residuals of the linear term. By default the +distortion terms is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are set to "none" regardless of the values of the \fIxxorder\fR, +\fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR and \fIyxterms\fR +parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic coordinate surfaces to be fit. The options are the +following. +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series polynomials in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the x and y fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an x and y shift, +an x and y scale change, and rotations of the x and y axes. The "shift", +"xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le + +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1, xyorder - 1) for the x fit and +MAX (yxorder - 1, yyorder - 1) for the y fit. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1 + xyorder - 1) for the x fit and +MAX (yxorder - 1 + yyorder - 1) for the y fit. +.le + +The "shift", "xyscale", "rotation", "rscale", and "rxyscale" fitting +geometries, assume that the cross term switches are set to "none"regardless +of the values set by the user. If either of the cross terms parameters is +set to "half" or "full" and \fIfitgeometry\fR is "general" then a distortion +surface is fit to the residuals from the linear portion of the fit. +.le + +.ls reject = INDEF +The rejection limit in units of sigma. The default is no rejection. +.le +.ls calctype = "real" +The precision of coordinate transformation calculations. The options are "real" +and "double". +.le +.ls verbose = yes +Print messages about the progress of the task? +.le +.ls interactive = yes +Run the task interactively ? +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, delete points, replot the data etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls gcommands = "" +The graphics cursor. +.le + +.ih +DESCRIPTION + +SKYMAP computes the spatial transformation function required to map the +celestial coordinate system of the reference image \fIreference\fR to +the celestial coordinate +system of the input image \fIinput\fR, and stores the computed function in +the output text database file \fIdatabase\fR. +The input and reference images may be 1D or 2D but +must have the same dimensionality. The input image and output +text database file can be input to the REGISTER or GEOTRAN tasks to +perform the actual image registration. SKYMAP assumes that the world +coordinate systems in the input and reference +image headers are accurate and that the two systems are compatible, e.g. both +images have a celestial coordinate system WCS. + +SKYMAP computes the required spatial transformation by matching the logical +x and y pixel coordinates of a grid of points +in the input image with the logical x and y pixels coordinates +of the same grid of points in the reference image, +using celestial coordinate information stored in the two image headers. +The coordinate grid consists of \fInx * ny\fR points evenly distributed +over the logical pixel space of interest in the reference image defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The logical x and y reference image pixel coordinates are transformed to +reference image celestial coordinates using +world coordinate information stored in the reference image header. +The reference image celestial coordinates are transformed to +input image celestial coordinates using world coordinate +system information in both the reference and the input image headers. +Finally the input image celestial coordinates are transformed to logical x and y +input image pixel coordinates using world coordinate system information +stored in the input image header. The transformation sequence looks +like the following for an equatorial celestial coordinate system: + +.nf + (x,y) reference -> (ra,dec) reference (reference image wcs) +(ra,dec) reference -> (ra,dec) input (reference and input image wcs) + (ra,dec) input -> (x,y) input (input image wcs) +.fi + +The computed reference and input logical coordinates and the +world coordinates are written to temporary coordinates file which is +deleted on task termination. +The pixel and celestial coordinates are written using +the \fIxformat\fR and \fIyformat\fR and the \fIrwxformat\fR, \fIrwyformat\fR, +\fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the celestial coordinates a format attribute cannot be +read from either the reference or the input images, reasonable default +formats are chosen. +If the reference and input images are 1D then all the output logical and +world y coordinates are set to 1. + +SKYMAP computes a spatial transformation of the following form. + +.nf + xin = f (xref, yref) + yin = g (xref, yref) +.fi + +The functions f and g are either a power series polynomial or a Legendre or +Chebyshev polynomial surface of order \fIxxorder\fR and \fIxyorder\fR in x +and \fIyxorder\fR and \fIyyorder\fR in y. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a13' * yref ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a22 * xref * yref + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a22' * xref * yref + a13' * yref ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a31 * xref ** 2 + + a12 * yref + a22 * xref * yref + a32 * xref ** 2 * yref + + a13 * yref ** 2 + a23 * xref * yref ** 2 + + a33 * xref ** 2 * yref ** 2 + yin = a11' + a21' * xref + a31' * xref ** 2 + + a12' * yref + a22' * xref * yref + a32' * xref ** 2 * yref + + a13' * yref ** 2 + a23' * xref * yref ** 2 + + a33' * xref ** 2 * yref ** 2 +.fi + +If the \fBfitgeometry\fR parameter is anything other than "general", the +order parameters assume the value 2 and the cross terms switches assume +the value "none", regardless of the values set by the user. The computation +can be done in either real or double precision by setting the \fIcalctype\fR +parameter. Automatic pixel rejection may be enabled by setting the \fIreject\fR +parameter to a positive number other than INDEF. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not necessarily correspond to a physically meaningful model. +However the computed +coefficients for the linear term can be given a simple geometrical geometric +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + + fitting geometry = shift + xin = a + xref + yin = d + yref + + fitting geometry = xyscale + xin = a + b * xref + yin = d + f * yref + + fitting geometry = rotate + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const +.fi + + +The coefficients can be interpreted as follows. Xref0, yref0, xin0, yin0 +are the origins in the reference and input frames respectively. Orientation +and skew are the orientation of the x and y axes and their deviation from +perpendicularity respectively. Xmag and ymag are the scaling factors in x and +y and are assumed to be positive. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xin0 - xref0 = xshift + d = yin0 - yref0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xin0 - b * xref0 = xshift + d = yin0 - f * yref0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift +.fi + + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the region of +validity of the fit as well as the limits of the grid +in the reference coordinate system. These parameters are also used to +reject out of range data before the actual fitting is done. + +Each computed transformation is written to the output file \fIdatabase\fR +in a record whose name is supplied by the user via the \fItransforms\fR +parameter or set to the name of the corresponding input image. +The database file is opened in append mode and new records are written +to the end of the existing file. If more that one record of the same +name is written to the database file, the last record written is the +valid record, i.e. the one that will be used by the REGISTER or +GEOTRAN tasks. + +SKYMAP will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the celestial coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the celestial <-> logical coordinate systems cannot be compiled for either +or both images, or the celestial coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image. +This grid of points defines an identity transformation which will leave +the input image unchanged if applied by the REGISTER or GEOTRAN tasks. + +If \fIverbose\fR is "yes" then messages about the progress of the task +as well as warning messages indicating potential problems are written to +the standard output. If \fIresults\fR is set to a file name then the input +coordinates, the fitted coordinates, and the residuals of the fit are +written to that file. + +SKYMAP may be run interactively by setting the \fIinteractive\fR +parameter to "yes". +In interactive mode the user has the option of viewing the fit, changing the +fit parameters, deleting and undeleting points, and replotting +the data until a satisfactory +fit has been achieved. + +.ih +CURSOR COMMANDS + +In interactive mode the following cursor commands are currently available. + +.nf + Interactive Keystroke Commands + +? Print options +f Fit the data and graph with the current graph type (g, x, r, y, s) +g Graph the data and the current fit +x,r Graph the x fit residuals versus x and y respectively +y,s Graph the y fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the constant x, y plotting option +t Plot a line of constant x, y through the nearest data point +l Print xshift, yshift, xmag, ymag, xrotate, yrotate +q Exit the interactive curve fitting +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name alone will list the current value. + +.nf + Colon Parameter Editing Commands + +:show List parameters +:fitgeometry Fitting geometry (shift,xyscale,rotate, + rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre, + polynomial) +:xxorder :xyorder [value] X fitting function xorder, yorder +:yxorder :yyorder [value] Y fitting function xorder, yorder +:xxterms :yxterms [n/h/f] X, Y fit cross terms type +:reject [value] Rejection threshold +.fi + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be found in the help pages for the WCSEDIT +and WCRESET tasks. Detailed documentation for the IRAF world +coordinate system interface MWCS can be found in the file +"iraf$sys/mwcs/MWCS.hlp". This file can be formatted and printed +with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + +.ih +EXAMPLES + +1. Compute the spatial transformation required to match a radio image to an +X-ray image of the same field using a 100 point coordinate grid +and a simple linear transformation. Both images have accurate sky +equatorial world coordinate systems define at different equinoxes. +Print the output world coordinates +in the coords file in hh:mm:ss.ss and dd:mm:ss.s format. Run geotran +on the results to do the actual registration. + +.nf + cl> skymap radio xray geodb rwxformat=%12.2H rwyformat=%12.1h \ + wxformat=%12.2H wyformat=%12.1h interactive- + + cl> geotran radio radio.tran geodb radio +.fi + +2. Repeat the previous command but begin with a higher order fit +and run the task in interactive mode in order to examine the fit +residuals. + +.nf + cl> skymap radio xray geodb rwxformat=%12.2H rwyformat=%12.1h \ + wxformat=%12.2H wyformat=%12.1h xxo=4 xyo=4 xxt=half \ + yxo=4 yyo=4 yxt=half + + ... a plot of the fit appears + + ... type x and r to examine the residuals of the x + surface fit versus x and y + + ... type y and s to examine the residuals of the y + surface fit versus x and y + + ... delete 2 deviant points with the d key and + recompute the fit with the f key + + ... type q to quit and save the fit + + cl> geotran radio radio.tran geodb radio +.fi + +3. Repeat example 1 but set the transform name specifically. + +.nf + cl> skymap radio xray geodb trans=m82 rwxformat=%12.2H \ + rwyformat=%12.1h wxformat=%12.2H wyformat=%12.1h \ + interactive- + + cl> geotran radio radio.tran geodb m82 +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +wcsctran,register,geotran +.endhelp diff --git a/pkg/images/immatch/doc/skyxymatch.hlp b/pkg/images/immatch/doc/skyxymatch.hlp new file mode 100644 index 00000000..63485284 --- /dev/null +++ b/pkg/images/immatch/doc/skyxymatch.hlp @@ -0,0 +1,406 @@ +.help skyxymatch Dec96 images.immatch +.ih +NAME +skyxymatch -- match input and reference image x-y coordinates using the +celestial coordinate WCS +.ih +USAGE +skyxymatch input reference output +.ih +PARAMETERS +.ls input +The list of input images containing the input celestial coordinate wcs. +.le +.ls reference +The list of reference images containing the reference celestial coordinate +wcs. The number of reference images must be one or equal to the number +of input images. +.le +.ls output +The output matched coordinate lists containing: +1) the logical x-y pixel coordinates of a point +in the reference image in columns 1 and 2, 2) the logical x-y pixel +coordinates of the same point in the input image in columns 3 and 4, +3) the world coordinates of the point in the reference image in columns +5 and 6, and 4) the world coordinate of the point in the input image in +columns 7 and 8. The output coordinate list can be +input directly to the geomap task. The number of output files must be +equal to the number of input images or be the standard output STDOUT. +.le +.ls coords = "grid" +The source of the coordinate list. The options are: +.ls grid +Generate a list of \fInx * ny\fR coordinates evenly spaced over +the reference image, and beginning and ending at logical coordinates +\fIxmin\fR and \fIxmax\fR in x and \fIymin\fR and \fIymax\fR in y. +.le +.ls +The name of the text file containing the world coordinates of a set of +points in the reference image. +.le +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to generate +the grid of control points if \fIcoords\fR = "grid". Xmin, xmax, ymin, and +ymax default to 1, the number of columns in the reference image, 1, and the +number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid +if \fIcoords\fR = "grid". +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in decimal degrees for the celestial coordinate systems. Obviously if the +wcs is correct the ra and dec of an object +should remain the same no matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +Care must be taken that the wcs of the input and +reference images are compatible, e.g. it makes no sense to +match the coordinates of a 2D sky projection and a 2D spectral wcs. +.le +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate list containing the x and y coordinate +values if \fIcoords\fR = . +.le +.ls xunits = "", ls yunits = "" +The units of the x and y coordinates in the input coordinate list +if \fIcoords\fR = , by default decimal degrees for celestial +coordinate systems, otherwise any units. +The options are: +.ls hours +Input coordinates specified in hours are converted to decimal degrees by +multiplying by 15.0. +.le +.ls native +The internal units of the wcs. No conversions on the input coordinates +are performed. +.le + +If the units are not specified the default is "native". +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls rwxformat = "", rwyformat = "" +The format of the output world x and y reference image coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for sky projection coordinates. +.le +.ls wxformat = "", wyformat = "" +The format of the output world x and y input image coordinates +in columns 7 and 8 respectively. The internal default formats will give +reasonable output formats and precision for sky projection coordinates. +.le +.ls min_sigdigits = 7 +The minimum precision of the output coordinates if, the formatting parameters +are undefined, or the output world coordinate system is "world" and the wcs +cannot be decoded. +.le +.ls verbose = yes +Print messages about the progress of the task? +.le + +.ih +DESCRIPTION + +SKYXYMATCH matches the logical x and y pixel coordinates of a set of points +in the input image \fIinput\fR with the logical x and y pixels coordinates +of the same points in the reference image \fIreference\fR +using world celestial coordinate information +in the image headers. SKYXYMATCH writes its results to the +coordinate file \fIoutput\fR which is suitable for input to the GEOMAP task. +The input and reference images may be 1D or 2D but must both have +the same dimensionality. + +If \fIcoords\fR = "grid", SKYXYMATCH computes a grid of \fInx * ny\fR +logical x and y pixel coordinates evenly distributed over the +logical pixel space of the reference image defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The logical x and y reference image pixel coordinates are transformed to +reference image celestial coordinates using +world coordinate information stored in the reference image header. +The reference image celestial coordinates are transformed to +input image celestial coordinates using world coordinate +system information in both the reference and the input image headers. +Finally the input image celestial coordinates are transformed to logical x and y +input image pixel coordinates using world coordinate system information +stored in the input image header. The transformation sequence looks +like the following for an equatorial celestial coordinate system: + +.nf + (x,y) reference -> (ra,dec) reference (reference image wcs) +(ra,dec) reference -> (ra,dec) input (reference and input image wcs) + (ra,dec) input -> (x,y) input (input image wcs) +.fi + +The reference and input image celestial coordinate systems +may be equatorial, ecliptic, galactic, or supergalactic. The equatorial systems +may be one of: 1) the mean place pre-IAU 1976 (FK4) system, 2) +the same as FK4 but without the E-terms (FK4-NO-E) system, 3) the mean +place post-IAU +1976 (FK5) system, 4) or the geocentric apparent place in the post-IAU 1976 +(GAPPT) system. + +SKYXYMATCH assumes that the celestial coordinate system is specified by the FITS +keywords CTYPE, CRPIX, CRVAL, CD (or alternatively CDELT / CROTA), RADECSYS, +EQUINOX (or EPOCH), MJD-WCS (or MJD-OBS, or DATE-OBS). USERS SHOULD TAKE NOTE +THAT MJD-WCS IS CURRENTLY NEITHER A STANDARD OR A PROPOSED STANDARD FITS +KEYWORD. HOWEVER IT OR SOMETHING SIMILAR, IS REQUIRED TO SPECIFY THE EPOCH OF +THE COORDINATE SYSTEM WHICH MAY BE DIFFERENT FROM THE EPOCH OF THE OBSERVATION. + +The first four characters of the values of the ra / longitude and dec / latitude +axis CTYPE keywords specify the celestial coordinate system. The currently +permitted values of CTYPE[1:4] are RA-- / DEC- for equatorial coordinate +systems, ELON / ELAT for the ecliptic coordinate system, GLON / GLAT for the +galactic coordinate system, and SLON / SLAT for the supergalactic coordinate +system. + +The second four characters of the values of the ra / longitude and dec / +latitude axis CTYPE keywords specify the sky projection geometry. IRAF +currently supports the TAN, SIN, ARC, and GLS geometries, and consequently the +currently permitted values of CTYPE[5:8] are -TAN, -ARC, -SIN, and -GLS. +SKYXYMATCH fully supports the TAN, SIN, and ARC projections, but does not fully +support the GLS projection. + +If the image celestial coordinate systems are equatorial, the value of the +RADECSYS keyword specifies which fundamental equatorial system is to be +considered. The permitted values of RADECSYS are FK4, FK4-NO-E, FK5, and GAPPT. +If the RADECSYS keyword is not present in the image header, the values of the +EQUINOX / EPOCH keywords (in that order of precedence) are used to determine +the fundamental equatorial coordinate system. EQUINOX or EPOCH contain the +epoch of the mean place and equinox for the FK4, FK4-NO-E, and FK5 systems +(e.g 1950.0 or 2000.0). The default equatorial system is FK4 if EQUINOX or +EPOCH < 1984.0, FK5 if EQUINOX or EPOCH >= 1984.0, and FK5 if RADECSYS, EQUINOX, +and EPOCH are undefined. If RADECSYS is defined but EQUINOX and EPOCH are not, +the equinox defaults to 1950.0 for the FK4 and FK4-NO-E systems, and 2000.0 for +the FK5 system. The equinox value is interpreted as a Besselian epoch for the +FK4 and FK4-NO-E systems, and as a Julian epoch for the FK5 system. Users are +strongly urged to use the EQUINOX keyword in preference to the EPOCH keyword, +if they must enter their own equinox values into the image header. The FK4 and +FK4-NO-E systems are not inertial and therefore also require the epoch of the +observation (the time when the mean place was correct), in addition to the +equinox. The epoch is specified, in order of precedence, by the values of the +keywords MJD-WCS or MJD-OBS (which contain the modified Julian date, JD - +2400000.5, of the coordinate system), or the DATE-OBS keyword (which contains +the date of the observation in the form DD/MM/YY, CCYY-MM-DD, +CCYY-MM-DDTHH:MM:SS.S). As the latter quantity is +only accurate to a day, the MJD-WCS or MJD-OBS specification is preferred. +If all 3 keywords are absent the epoch defaults to the value of equinox. +Equatorial coordinates in the GAPPT system require only the specification +of the epoch of observation which is supplied via the MJD-WCS, MJD-OBS, +or DATE-OBS keywords (in that order of precedence) as for the FK4 and +FK4-NO-E system. + +If the image celestial coordinate systems are ecliptic the mean ecliptic +and equinox of date are required. These are read from the MJD-WCS, MJD-OBS, +or DATE-OBS keywords (in that order or precedence) as for the equatorial FK4, +FK4-NO-E, and GAPPT systems. + +USERS NEED TO BE AWARE THAT THE IRAF IMAGE WORLD COORDINATE SYSTEM +CURRENTLY (IRAF VERSIONS 2.10.4 PATCH 2 AND EARLIER) SUPPORTS ONLY THE +EQUATORIAL SYSTEM (CTYPE = "RA--XXXX" CTYPE = "DEC-XXXX") +WHERE XXXX IS THE PROJECTION TYPE, EVEN THOUGH THE SKYXYMATCH TASK +SUPPORTS GALACTIC, SUPERGALACTIC, AND ECLIPTIC coordinate systems. + +If \fIcoords\fR is a file name, SKYXYMATCH reads a list of x and y +reference image world coordinates from columns \fIxcolumn\fR and \fIycolumn\fR +in the input coordinates file and transforms these coordinates to +"native" coordinate units using the \fIxunits\fR and \fIyunits\fR parameters. +The reference image world coordinates are +transformed to logical reference and input image coordinates +using the value of the \fIwcs\fR parameter and world coordinate +information in the reference and input image headers. + +SKYXYMATCH will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the world coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the world <-> logical coordinate systems cannot be compiled for either +or both images, or the world coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image, +and defining an identify transformation, is written to the output file. + +The computed reference and input logical and world coordinates +are written to the output file using +the \fIxformat\fR and \fIyformat\fR, \fIrwxformat\fr, \fIrwyformat\fR, +and the \fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the world coordinates, a format attribute cannot be +read from either the reference or the input images reasonable defaults are +chosen. + +If the reference and input images are 1D then the +output logical and world y coordinates are +set to 1. + +If \fIverbose\fR is "yes" then a title section is written to the output +file for each set of computed coordinates, along with messages about +what if anything went wrong with the computation. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be found in the help pages for the WCSEDIT +and WCRESET tasks. Detailed documentation for the IRAF world +coordinate system interface MWCS can be found in the file +"iraf$sys/mwcs/MWCS.hlp". This file can be formatted and printed +with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + +.ih +EXAMPLES + +1. Compute a matched list of 100 logical x and y coordinates for an X-ray +and radio image of the same field, both of which have accurate sky +projection world coordinate systems with different equinoxes. Print the +output world coordinates in hh:mm:ss.ss and dd:mm:ss.s format + +.nf + cl> skyxymatch image refimage coords rwxformat=%12.2H \ + rwyformat=%12.1h wxformat=%12.2H wyformat=%12.1h +.fi + +2. Given a list of ras and decs of objects in the reference image, +compute a list of matched logical x and y coordinates for the two images, +both of which have a accurate sky projection wcss, although the reference +wcs is in equatorial coordinates and the input wcs is in galactic +coordinates. The ras and decs are in +columns 3 and 4 of the input coordinate file and are in hh:mm:ss.ss and +dd:mm:ss.s format respectively. Print the output world coordinates +in the same units as the input. + +.nf + cl> skyxymatch image refimage coords coords=radecs \ + xcolumn=3 ycolumn=4 xunits=hours rwxformat=%12.2H \ + rwyformat=%12.1h wxformat=%12.2H wyformat=%12.1h +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +skyctran,wcsctran,geomap,geotran,skymap,sregister +.endhelp diff --git a/pkg/images/immatch/doc/sregister.hlp b/pkg/images/immatch/doc/sregister.hlp new file mode 100644 index 00000000..5bc829c5 --- /dev/null +++ b/pkg/images/immatch/doc/sregister.hlp @@ -0,0 +1,779 @@ +.help sregister Dec98 images.immatch +.ih +NAME +sregister -- register a list of images to a reference image using celestial +coordinate WCS information +.ih +USAGE +sregister input reference output +.ih +PARAMETERS +.ls input +The list of input images containing the input celestial coordinate wcs. +.le +.ls reference +The list of reference images containing the reference celestial coordinate wcs. +The number of reference images must be one or equal to the number of +input images. +.le +.ls output +The list of output registered images. The number of output images must +be equal to the number of input images. +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to, generate +the grid of reference image control points, define the region of validity of +the spatial transformation, and define the extent of the output image. +Xmin, xmax, ymin, and +ymax are assigned defaults of 1, the number of columns in the reference +image, 1, and the number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid. +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in decimal degrees for celestial coordinate systems. Obviously if the +wcs is correct the ra and dec of an object +should remain the same no matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +Care must be taken that the wcs of the input and +reference images are compatible, e.g. it makes no sense to +match the coordinates of a 2D sky projection and a 2D spectral wcs. +.le +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls rwxformat = "", rwyformat = "" +The format of the output world x and y reference image coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for celestial coordinate +systems. +.le +.ls wxformat = "", wyformat = "" +The format of the output world x and y input image coordinates +in columns 7 and 8 respectively. The internal default formats will give +reasonable output formats and precision for celestial coordinate +systems. +.le +.ls fitgeometry = "general" +The fitting geometry to be used. The options are the following. +.ls shift +X and y shifts only are fit. +.le +.ls xyscale +X and y shifts and x and y magnification factors are fit. Axis flips are +allowed for. +.le +.ls rotate +X and y shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +X and y shifts, a magnification factor assumed to be the same in x and y, and a +rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +X and y shifts, x and y magnifications factors, and a rotation angle are fit. +Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes an x and y +shift, an x and y scale factor, a rotation and a skew. Axis flips are also +allowed for in the linear portion of the fit. The distortion term consists +of a polynomial fit to the residuals of the linear term. By default the +distortion terms is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are set to "none", regardless of the values of the \fIxxorder\fR, +\fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR and \fIyxterms\fR +parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic coordinate surfaces to be fit. The options are the +following: +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series polynomials in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the x and y fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an x and y shift, +an x and y scale change, and rotations of the x and y axes. The "shift", +"xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1, xyorder - 1) for the x fit and +MAX (yxorder - 1, yyorder - 1) for the y fit. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1 + xyorder - 1) for the x fit and +MAX (yxorder - 1 + yyorder - 1) for the y fit. +.le + +The "shift", "xyscale", "rotation", "rscale", and "rxyscale" fitting +geometries, assume that the cross term switches are set to "none"regardless +of the values set by the user. If either of the cross terms parameters is +set to "half" or "full" and \fIfitgeometry\fR is "general" then a distortion +surface is fit to the residuals from the linear portion of the fit. +.le + +.ls reject = INDEF +The rejection limit in units of sigma. The default is no rejection. +.le +.ls calctype = "real" +The precision of coordinate transformation calculations. The options are "real" +and "double". +.le +.ls geometry = "geometric" +The type of geometric transformation. The options are: +.ls linear +Perform only the linear part of the geometric transformation. +.le +.ls geometric +Compute both the linear and distortion portions of the geometric correction. +.le +.le +.ls xsample = 1.0, ysample = 1.0 +The coordinate surface subsampling factor. The coordinate surfaces are +evaluated at every xsample-th pixel in x and every ysample-th pixel in y. +Transformed coordinates at intermediate pixel values are determined by +bilinear interpolation in the coordinate surfaces. If the coordinate +surface is of high order setting these numbers to some reasonably high +value is recommended. +.le +.ls interpolant = "linear" +The interpolant used for rebinning the image. The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a user supplied constant value. +.le +.ls reflect +Generate a value by reflecting about the boundary of the image. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0.0 +The value of the constant for boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux? If flux conservation is turned on, the output +pixel values are multiplied by the Jacobian of the coordinate transformation. +.le +.ls nxblock = 512, nyblock = 512 +If the size of the output image is less than nxblock by nyblock then +the entire image is transformed at once. Otherwise the output image +is computed in blocks nxblock by nyblock pixels. +.le +.ls wcsinherit = yes +Inherit the wcs of the reference image? +.le +.ls verbose = yes +Print messages about the progress of the task? +.le +.ls interactive = no +Run the task interactively ? +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, delete points, replot the data etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls gcommands = "" +The graphics cursor. +.le + +.ih +DESCRIPTION + +SREGISTER computes the spatial transformation function required to register +the input image \fIinput\fR to the reference image \fIreference\fR, +and writes the registered input image to the output image \fIoutput\fR. +The input and reference images may be 1D or 2D but must have +the same dimensionality. SREGISTER assumes that the world +coordinate systems in the input and reference +image headers are accurate and that both systems are compatible, e.g. both +images have a celestial coordinate system WCS. + +SREGISTER computes the required spatial transformation by matching the logical +x and y pixel coordinates of a grid of points +in the input image with the logical x and y pixels coordinates +of the same grid of points in the reference image, +using world coordinate information stored in the two image headers. +The coordinate grid consists of \fInx * ny\fR points evenly distributed +over the logical pixel space of interest in the reference image defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The reference image celestial coordinates are transformed to +input image celestial coordinates using world coordinate +system information in both the reference and the input image headers. +Finally the input image celestial coordinates are transformed to logical x and y +input image pixel coordinates using world coordinate system information +stored in the input image header. The transformation sequence looks +like the following for an equatorial celestial coordinate system: + +.nf + (x,y) reference -> (ra,dec) reference (reference image wcs) +(ra,dec) reference -> (ra,dec) input (reference and input image wcs) + (ra,dec) input -> (x,y) input (input image wcs) +.fi + +The computed reference and input logical coordinates and the +celestial coordinates are written to a temporary output coordinates file +which is deleted on task termination. The pixel and celestial coordinates +are output using the \fIxformat\fR and \fIyformat\fR and the \fIrwxformat\fR, +\fIrwyformat\fR, \fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the celestial coordinates a format attribute cannot be +read from either the reference or the input images, the coordinates are +output in %g format with \fImin_sigdigits\fR digits of precision. +If the reference and input images are 1D then all the output logical and +world y coordinates are set to 1. + +SREGISTER computes a spatial transformation of the following form. + +.nf + xin = f (xref, yref) + yin = g (xref, yref) +.fi + +The functions f and g are either a power series polynomial or a Legendre or +Chebyshev polynomial surface of order +\fIxxorder\fR and \fIxyorder\fR in x and \fIyxorder\fR and \fIyyorder\fR in y. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a13' * yref ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a22 * xref * yref + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a22' * xref * yref + a13' * yref ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a31 * xref ** 2 + + a12 * yref + a22 * xref * yref + a32 * xref ** 2 * yref + + a13 * yref ** 2 + a23 * xref * yref ** 2 + + a33 * xref ** 2 * yref ** 2 + yin = a11' + a21' * xref + a31' * xref ** 2 + + a12' * yref + a22' * xref * yref + a32' * xref ** 2 * yref + + a13' * yref ** 2 + a23' * xref * yref ** 2 + + a33' * xref ** 2 * yref ** 2 +.fi + + +The computation can be done in either real or +double precision by setting the \fIcalctype\fR parameter. +Automatic pixel rejection may be enabled by setting the \fIreject\fR +parameter to some number > 0.0. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not correspond to a physically meaningful model. However the computed +coefficients for the linear term can be given a simple geometrical geometric +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + + fitting geometry = shift + xin = a + xref + yin = d + yref + + fitting geometry = xyscale + xin = a + b * xref + yin = d + f * yref + + fitting geometry = rotate + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const +.fi + +The coefficients can be interpreted as follows. Xref0, yref0, xin0, yin0 +are the origins in the reference and input frames respectively. Orientation +and skew are the orientation of the x and y axes and their deviation from +perpendicularity respectively. Xmag and ymag are the scaling factors in x and +y and are assumed to be positive. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xin0 - xref0 = xshift + d = yin0 - yref0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xin0 - b * xref0 = xshift + d = yin0 - f * yref0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift +.fi + + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the region of +validity of the transformation as well as the limits of the grid +in the reference coordinate system. + +Each computed transformation is written to the a temporary output text database +file which is deleted on task termination. Otherwise the +database file is opened in append mode and new records are written +to the end of the existing file. If more that one record of the same +name is written to the database file, the last record written is the +valid record. + +SREGISTER will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the world coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the world <-> logical coordinate systems cannot be compiled for either +or both images, or the world coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image. +This grid of points defines an identity transformation which results in +an output image equal to the input image. + +SREGISTER computes the output image by evaluating the fitted coordinate +surfaces and interpolating in the input image at position of the transformed +coordinates. The scale of the output image is the same as the scale of the +reference image. The extent and size of the output image are determined +by the \fIxmin\fR, \fIxmax\fR, \fIymin\fR, and \fIymax\fR parameters +as shown below + +.nf + xmin <= x <= xmax + ymin <= x <= ymax + ncols = xmax - xmin + 1 + nlines = xmax - xmin + 1 +.fi + +SREGISTER samples the coordinate surfaces at every \fIxsample\fR and +\fIysample\fR pixels in x and y. +The transformed coordinates at intermediate pixel values are +determined by bilinear interpolation in the coordinate surface. If +\fIxsample\fR and \fIysample\fR = 1, the coordinate +surface is evaluated at every pixel. Use of \fIxsample\fR and \fIysample\fR +are strongly recommended for large images and high order coordinate +surfaces in order to reduce the time required to compute the output image. + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels using the +interpolant specified by the \fIinterpolant\fR parameter. If the +\fIfluxconserve\fR switch is set the output pixel values are multiplied by +the Jacobian of the transformation, which preserves the flux of the entire +image. Out-of-bounds pixels are evaluated using the \fIboundary\fR and +\fIconstant\fR parameters. + +The output image is computed in \fInxblock\fR by \fInyblock\fR pixel sections. +If possible users should set these number to values larger than the dimensions +of the output image in order to minimize the number of disk reads and writes +required to compute the output image. If this is not feasible and the image +rotation is small, users should set nxblock to be greater than the number of +columns in the output image, and nyblock to be as large as machine memory +will permit. + +If \fIwcsinherit\fR = "yes", then the output image will inherit the world +coordinate system of the reference image. +Otherwise if the environment variable \fInomwcs\fR is "no" the world +coordinate +system of the input image is modified in the output image to reflect the +effects of the \fIlinear\fR portion of the registration operation. +Support does not yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that SREGISTER is capable +of performing. + +If \fIverbose\fR is "yes" then messages about the progress of the task +as well as warning messages indicating potential problems +are written to the standard output. + +SREGISTER may be run interactively by setting the \fIinteractive\fR +parameter to "yes". +In interactive mode the user has the option of viewing the fitted +spatial transformation, changing the +fit parameters, deleting and undeleting points, and replotting +the data until a satisfactory +fit has been achieved. + +.ih +CURSOR COMMANDS + +In interactive mode the following cursor commands are currently available. + +.nf + Interactive Keystroke Commands + +? Print options +f Fit the data and graph with the current graph type (g, x, r, y, s) +g Graph the data and the current fit +x,r Graph the x fit residuals versus x and y respectively +y,s Graph the y fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the constant x, y plotting option +t Plot a line of constant x, y through the nearest data point +l Print xshift, yshift, xmag, ymag, xrotate, yrotate +q Exit the interactive curve fitting +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name alone will list the current value. + +.nf + Colon Parameter Editing Commands + +:show List parameters +:fitgeometry Fitting geometry (shift,xyscale,rotate, + rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre, + polynomial) +:xxorder :xyorder [value] X fitting function xorder, yorder +:yxorder :yyorder [value] Y fitting function xorder, yorder +:xxterms :yxterms [n/h/f] X, Y fit cross term types +:reject [value] Rejection threshold +.fi + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be found in the help pages for the WCSEDIT +and WCRESET tasks. Detailed documentation for the IRAF world +coordinate system interface MWCS can be found in the file +"iraf$sys/mwcs/MWCS.hlp". This file can be formatted and printed +with the command "help iraf$sys/mwcs/MWCS.hlp fi+ | lprint". + +Details of the FITS header world coordinate system interface can +be found in the draft paper "World Coordinate Systems Representations Within the +FITS Format" by Hanisch and Wells, available from the iraf anonymous ftp +archive and the draft paper which supersedes it "Representations of Celestial +Coordinates in FITS" by Greisen and Calabretta available from the NRAO +anonymous ftp archives. + +The spherical astronomy routines employed here are derived from the Starlink +SLALIB library provided courtesy of Patrick Wallace. These routines +are very well documented internally with extensive references provided +where appropriate. Interested users are encouraged to examine the routines +for this information. Type "help slalib" to get a listing of the SLALIB +routines, "help slalib opt=sys" to get a concise summary of the library, +and "help " to get a description of each routine's calling sequence, +required input and output, etc. An overview of the library can be found in the +paper "SLALIB - A Library of Subprograms", Starlink User Note 67.7 +by P.T. Wallace, available from the Starlink archives. + +.ih +EXAMPLES + +1. Register a radio image to an X-ray image of the same field using +a 100 point coordinate grid and a simple linear transformation. Both +images have accurate sky projection world coordinate systems. Print the +output world coordinates in the coords file in hh:mm:ss.ss and dd:mm:ss.s +format. Display the input and output image and blink them. + +.nf + cl> sregister radio xray radio.tran rwxformat=%12.2H \ + rwyformat=%12.1h wxformat=%12.2H wyformat=%12.1h + + cl> display radio 1 fi+ + + cl> display radio.tran 2 fi+ +.fi + +2. Repeat the previous command but begin with a higher order fit +and run the task in interactive mode in order to examine the fit +residuals. + +.nf + cl> sregister radio xray radio.tran rwxformat=%12.2H \ + rwyformat=%12.1h wxformat=%12.2H wyformat=%12.1h xxo=4 \ + xyo=4 xxt=half yxo=4 yyo=4 yxt=half inter+ + + ... a plot of the fit appears + + ... type x and r to examine the residuals of the x + surface fit versus x and y + + ... type y and s to examine the residuals of the y + surface fit versus x and y + + ... delete 2 deviant points with the d key and + recompute the fit with the f key + + ... type q to quit, save the fit, and compute the registered + image +.fi + + +3. Mosaic a set of 9 images covering a ~ 1 degree field into a single image +centered at 12:32:53.1 +43:13:03. Set the output image scale to 0.5 +arc-seconds / pixel which is close the detector scale of 0.51 arc-seconds +per pixel. Set the orientation to be north up and east to the left. +The 9 images all have accurate world coordinate information in their headers. + +.nf + # Create a dummy reference image big enough to cover 1 square degree + + cl> mkpattern refimage ncols=7200 nlines=7200 ... + + # Give the dummy reference image the desired coordinate system + + cl> ccsetwcs refimage "" xref=3600.5 yref=3600.5 xmag=-0.5 \ + ymag=0.5 lngref=12:32:53.1 latref=43:13:03 ... + + # Register the images using constant boundary extension and set + # uservalue to some reasonable value outside the good data range. + # It may be possible to improve performance by increasing nxblock + # and nyblock. + + cl> sregister @inlist refimage @outlist boundary=constant \ + constant= nxblock=7200 nyblock=1024 ... + + # Combine the images using imcombine + + cl> imcombine @outlist mosaic lthreshold= ... + +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imalign,xregister,register,geotran,wregister +.endhelp diff --git a/pkg/images/immatch/doc/wcscopy.hlp b/pkg/images/immatch/doc/wcscopy.hlp new file mode 100644 index 00000000..493f1311 --- /dev/null +++ b/pkg/images/immatch/doc/wcscopy.hlp @@ -0,0 +1,80 @@ +.help wcscopy Jun95 images.immatch +.ih +NAME +wcscopy -- copy the wcs of a reference image to a list of images +.ih +USAGE +wcscopy images refimages +.ih +PARAMETERS +.ls images +The list of input images which will inherit the wcs of the reference image. +If the image does not exists a dataless image header is created. +.le +.ls reference +The list of reference images containing the reference wcs. The number of +reference images must be one or equal to the number of input images. +.le +.ls verbose = yes +Print messages about the progress of the task? +.le + +.ih +DESCRIPTION + +WCSCOPY copies the world coordinate system information in the header of the +reference image \fIreference\fR to the headers of the input images +\fIimages\fR, replacing any existing world coordinate system information +in the input image headers in the process. WCSCOPY assumes that the +world coordinate system information in the header of the reference +image is accurate and that all the input images have write permission. +If the input image does not exist a data-less image header is created. +The WCS is treated as an independent object and +there is no check made on the dimensionality and sizes of the images. + + +.ih +REFERENCES + +Information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be +found in the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system +interface MWCS can be found in the file "iraf$sys/mwcs/MWCS.hlp". +This file can be formatted and printed with the command "help +iraf$sys/mwcs/MWCS.hlp fi+ | lprint". Information on the spectral +coordinates systems and their suitability for use with WCSXYMATCH +can be obtained by typing "help specwcs | lprint". +Details of the FITS header +world coordinate system interface can be found in the document +"World Coordinate Systems Representations Within the FITS Format" +by Hanisch and Wells, available from our anonymous ftp archive. + +.ih +EXAMPLES + +1. Make sure that the world coordinates systems of a list of input images +that have been registered to a reference image with the xregister task +are identical to the world coordinate system of the reference image. + +.nf + cl> xregister @inlist refimage [200:400,200:400] shifts \ + output=@outlist xwindow=21 ywindow=21 + cl> wcscopy @outlist refimage +.fi + +2. Create a data-less WCS image by specifying a new image. + +.nf + cl> wcscopy new dev$wpix +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +tprecess,imalign,xregister,geomap,register,geotran,wcsmap,wregister,wcsedit +.endhelp diff --git a/pkg/images/immatch/doc/wcsmap.hlp b/pkg/images/immatch/doc/wcsmap.hlp new file mode 100644 index 00000000..e2a4dd01 --- /dev/null +++ b/pkg/images/immatch/doc/wcsmap.hlp @@ -0,0 +1,619 @@ +.help wcsmap Feb96 images.immatch +.ih +NAME +wcsmap -- compute the spatial transformation function required to register +a list of images using WCS information +.ih +USAGE +wcsmap input reference database +.ih +PARAMETERS +.ls input +The list of input images containing the input wcs. +.le +.ls reference +The list of reference images containing the reference wcs. The number of +reference images must be one or equal to the number of input images. +.le +.ls database +The name of the output text database file containing the computed +transformations. +.le +.ls transforms = "" +An optional list of transform names. If transforms is undefined the +transforms are assigned record names identical to the names of the input images. +.le +.ls results = "" +Optional output files containing a summary of the results including a +description of the transform geometry and a listing of the input coordinates, +the fitted coordinates, and the fit residuals. The number of results files +must be one or equal to the number of input files. If results is "STDOUT" the +results summary is printed on the standard output. +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to generate +the grid of reference image control points and define the region of +validity of the spatial transformation. Xmin, xmax, ymin, and +ymax are assigned defaults of 1, the number of columns in the reference +image, 1, and the number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid. +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in world units, normally decimal degrees for sky projection coordinate +systems and angstroms for spectral coordinate systems. Obviously if the +wcs is correct the ra and dec or wavelength and position of an object +should remain the same not matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +Care must be taken that the wcs of the input and +reference images are compatible, e.g. it makes no sense to +match the coordinates of a 2D sky projection and a 2D spectral wcs. +.le +.le +.ls transpose = no +Force a transpose of the reference image world coordinates before evaluating +the world to logical coordinate transformation for the input image ? This +option is useful if there is not enough information in the reference and +input image headers to tell whether or not the images are transposed with +respect to each other. +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls wxformat = "", wyformat = "" +The format of the output world x and y reference and input image coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for both sky projection coordinates +and other types, e.g. spectral, coordinates. +.le +.ls fitgeometry = "general" +The fitting geometry to be used. The options are the following. +.ls shift +X and y shifts only are fit. +.le +.ls xyscale +X and y shifts and x and y magnification factors are fit. Axis flips are +allowed for. +.le +.ls rotate +X and y shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +X and y shifts, a magnification factor assumed to be the same in x and y, and a +rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +X and y shifts, x and y magnifications factors, and a rotation angle are fit. +Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes an x and y +shift, an x and y scale factor, a rotation and a skew. Axis flips are also +allowed for in the linear portion of the fit. The distortion term consists +of a polynomial fit to the residuals of the linear term. By default the +distortion terms is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are set to "none", regardless of the values of the \fIxxorder\fR, +\fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR and \fIyxterms\fR +parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic coordinate surfaces to be fit. The options are the +following. +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series polynomials in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the x and y fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an x and y shift, +an x and y scale change, and rotations of the x and y axes. The "shift", +"xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1, xyorder - 1) for the x fit and +MAX (yxorder - 1, yyorder - 1) for the y fit. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1 + xyorder - 1) for the x fit and +MAX (yxorder - 1 + yyorder - 1) for the y fit. +.le + +The "shift", "xyscale", "rotation", "rscale", and "rxyscale" fitting +geometries, assume that the cross term switches are set to "none"regardless +of the values set by the user. If either of the cross terms parameters is +set to "half" or "full" and \fIfitgeometry\fR is "general" then a distortion +surface is fit to the residuals from the linear portion of the fit. +.le +.ls reject = INDEF +The rejection limit in units of sigma. The default is no rejection. +.le +.ls calctype = "real" +The precision of coordinate transformation calculations. The options are "real" +and "double". +.le +.ls verbose = yes +Print messages about the progress of the task? +.le +.ls interactive = yes +Run the task interactively ? +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, delete points, replot the data etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls gcommands = "" +The graphics cursor. +.le + +.ih +DESCRIPTION + +WCSMAP computes the spatial transformation function required to map the +coordinate system of the reference image \fIreference\fR to the coordinate +system of the input image \fIinput\fR, and stores the computed function in +the output text database file \fIdatabase\fR. +The input and reference images must be one- or two-dimensional and +must have the same dimensionality. The input image and output +text database file can be input to the REGISTER or GEOTRAN tasks to +perform the actual image registration. WCSMAP assumes that the world +coordinate systems in the input and reference +image headers are accurate and that the two systems are compatible, e.g. both +images have the same epoch sky projection world coordinate systems or both are +spectra whose coordinates are in the same units. + +WCSMAP computes the required spatial transformation by matching the logical +x and y pixel coordinates of a grid of points +in the input image with the logical x and y pixels coordinates +of the same grid of points in the reference image, +using world coordinate information stored in the two image headers. +The coordinate grid consists of \fInx * ny\fR points evenly distributed +over the logical pixel space of interest in the reference image defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The logical x and y pixel reference image coordinates are transformed to the +reference image world coordinate system defined by \fIwcs\fR, using the wcs +information in the reference image header. +The reference image world coordinates are then transformed to logical x and +y pixel coordinates in the input image, using world coordinate system +information stored in the input image header. + +The computed reference and input logical coordinates and the +world coordinates are written to a temporary output coordinates file which +is deleted on task termination. +The x and y coordinates are written using +the \fIxformat\fR and \fIyformat\fR and the \fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the world coordinates a format attribute cannot be +read from either the reference or the input images, the coordinates are +output in %g format with \fImin_sigdigits\fR digits of precision. +If the reference and input images are 1D then all the output logical and +world y coordinates are set to 1. + +WCSMAP computes a spatial transformation of the following form. + +.nf + xin = f (xref, yref) + yin = g (xref, yref) +.fi + +The functions f and g are either a power series polynomial or a Legendre or +Chebyshev polynomial surface of order \fIxxorder\fR and \fIxyorder\fR in +x and \fIyxorder\fR and \fIyyorder\fR in y. Cross terms are optional. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a13' * yref ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a22 * xref * yref + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a22' * xref * yref + a13' * yref ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a31 * xref ** 2 + + a12 * yref + a22 * xref * yref + a32 * xref ** 2 * yref + + a13 * yref ** 2 + a23 * xref * yref ** 2 + + a33 * xref ** 2 * yref ** 2 + yin = a11' + a21' * xref + a31' * xref ** 2 + + a12' * yref + a22' * xref * yref + a32' * xref ** 2 * yref + + a13' * yref ** 2 + a23' * xref * yref ** 2 + + a33' * xref ** 2 * yref ** 2 +.fi + +If the \fBfitgeometry\fR parameter is anything +other than "general", the order parameters assume the value 2 and the +cross terms switches assume the value "none", regardless of the values set +by the user. The computation can be done in either real or +double precision by setting the \fIcalctype\fR parameter. +Automatic pixel rejection may be enabled by setting the \fIreject\fR +parameter to some number > 0.0. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not correspond to a physically meaningful model. However the computed +coefficients for the linear term can be given a simple geometrical geometric +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + + fitting geometry = shift + xin = a + xref + yin = d + yref + + fitting geometry = xyscale + xin = a + b * xref + yin = d + f * yref + + fitting geometry = rotate + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const +.fi + + +The coefficients can be interpreted as follows. Xref0, yref0, xin0, yin0 +are the origins in the reference and input frames respectively. Orientation +and skew are the orientation of the x and y axes and their deviation from +perpendicularity respectively. Xmag and ymag are the scaling factors in x and +y and are assumed to be positive. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xin0 - xref0 = xshift + d = yin0 - yref0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xin0 - b * xref0 = xshift + d = yin0 - f * yref0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift +.fi + + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the region of +validity of the fit as well as the limits of the grid +in the reference coordinate system and must be set by +the user. These parameters are used to reject out of range data before the +actual fitting is done. + +Each computed transformation is written to the output file \fIdatabase\fR +in a record whose name is either specified by the user via the \fItransforms\fR +parameter or defaults the name of the input image. +The database file is opened in append mode and new records are written +to the end of the existing file. If more that one record of the same +name is written to the database file, the last record written is the +valid record, i.e. the one that will be used by the REGISTER or +GEOTRAN tasks. + +WCSMAP will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the world coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the world <-> logical coordinate systems cannot be compiled for either +or both images, or the world coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image. +This grid of points defines an identity transformation which will leave +the input image unchanged if applied by the REGISTER or GEOTRAN tasks. + +If \fIverbose\fR is "yes" then messages about the progress of the task +as well as warning messages indicating potential problems are written to +the standard output. If \fIresults\fR is set to a file name then the input +coordinates, the fitted coordinates, and the residuals of the fit are +written to that file. + +WCSMAP may be run interactively by setting the \fIinteractive\fR +parameter to "yes". +In interactive mode the user has the option of viewing the fit, changing the +fit parameters, deleting and undeleting points, and replotting +the data until a satisfactory +fit has been achieved. + +.ih +CURSOR COMMANDS + +In interactive mode the following cursor commands are currently available. + +.nf + Interactive Keystroke Commands + +? Print options +f Fit the data and graph with the current graph type (g, x, r, y, s) +g Graph the data and the current fit +x,r Graph the x fit residuals versus x and y respectively +y,s Graph the y fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the constant x, y plotting option +t Plot a line of constant x, y through the nearest data point +l Print xshift, yshift, xmag, ymag, xrotate, yrotate +q Exit the interactive curve fitting +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name alone will list the current value. + +.nf + Colon Parameter Editing Commands + +:show List parameters +:fitgeometry Fitting geometry (shift,xyscale,rotate, + rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre, + polynomial) +:xxorder :xyorder [value] X fitting function xorder, yorder +:yxorder :yyorder [value] Y fitting function xorder, yorder +:xxterms :yxterms [n/h/f] X, Y fit cross terms type +:reject [value] Rejection threshold +.fi + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be +found in the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system +interface MWCS can be found in the file "iraf$sys/mwcs/MWCS.hlp". +This file can be formatted and printed with the command "help +iraf$sys/mwcs/MWCS.hlp fi+ | lprint". Information on the spectral +coordinates systems and their suitability for use with WCSXYMATCH +can be obtained by typing "help specwcs | lprint". +Details of the FITS header +world coordinate system interface can be found in the document +"World Coordinate Systems Representations Within the FITS Format" +by Hanisch and Wells, available from our anonymous ftp archive. + +.ih +EXAMPLES + +1. Compute the spatial transformation required to match a radio image to an +X-ray image of the same field using a 100 point coordinate grid +and a simple linear transformation. Both images have accurate sky +projection world coordinate systems. Print the output world coordinates +in the coords file in hh:mm:ss.ss and dd:mm:ss.s format. Run geotran +on the results to do the actual registration. + +.nf + cl> wcsmap radio xray geodb wxformat=%12.2H wyformat=%12.1h \ + interactive- + + cl> geotran radio radio.tran geodb radio +.fi + +2. Repeat the previous command but begin with a higher order fit +and run the task in interactive mode in order to examine the fit +residuals. + +.nf + cl> wcsmap radio xray geodb wxformat=%12.2H wyformat=%12.1h \ + xxo=4 xyo=4 xxt=half yxo=4 yyo=4 yxt=half + + ... a plot of the fit appears + + ... type x and r to examine the residuals of the x + surface fit versus x and y + + ... type y and s to examine the residuals of the y + surface fit versus x and y + + ... delete 2 deviant points with the d key and + recompute the fit with the f key + + ... type q to quit and save the fit + + cl> geotran radio radio.tran geodb radio +.fi + +3. Repeat example 1 but assign a user name to the transform. + +.nf + cl> wcsmap radio xray geodb transforms="m82" wxformat=%12.2H \ + wyformat=%12.1h interactive- + + cl> geotran radio radio.tran geodb m82 +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +wcstran,xregister,wcsxymatch,geomap,register,geotran +.endhelp diff --git a/pkg/images/immatch/doc/wcsxymatch.hlp b/pkg/images/immatch/doc/wcsxymatch.hlp new file mode 100644 index 00000000..0651b0c7 --- /dev/null +++ b/pkg/images/immatch/doc/wcsxymatch.hlp @@ -0,0 +1,314 @@ +.help wcsxymatch Jun95 images.immatch +.ih +NAME +wcsxymatch -- match input and reference image x-y coordinates using the WCS +.ih +USAGE +wcsxymatch input reference output +.ih +PARAMETERS +.ls input +The list of input images containing the input wcs. +.le +.ls reference +The list of reference images containing the reference wcs. The number of +reference images must be one or equal to the number of input images. +.le +.ls output +The output matched coordinate lists containing: +1) the logical x-y pixel coordinates of a point +in the reference image in columns 1 and 2, 2) the logical x-y pixel +coordinates of the same point in the input image in columns 3 and 4, +3) the world coordinates of the point in the reference and input +image in columns 5 and 6. The output coordinate list can be +input directly to the geomap task. The number of output files must be +equal to the number of input images or be the standard output STDOUT. +.le +.ls coords = "grid" +The source of the coordinate list. The options are: +.ls grid +Generate a list of \fInx * ny\fR coordinates, evenly spaced over +the reference image, and beginning and ending at logical coordinates +\fIxmin\fR and \fIxmax\fR in x and \fIymin\fR and \fIymax\fR in y. +.le +.ls +The name of the text file containing the world coordinates of a set of +points in the reference image. +.le +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to generate +the grid of control points if \fIcoords\fR = "grid". Xmin, xmax, ymin, and +ymax default to 1, the number of columns in the reference image, 1, and the +number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid +if \fIcoords\fR = "grid". +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in world units, normally decimal degrees for sky projection coordinate +systems and angstroms for spectral coordinate systems. Obviously if the +wcs is correct the ra and dec or wavelength and position of an object +should remain the same not matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +Care must be taken that the wcs of the input and +reference images are compatible, e.g. it makes no sense to +match the coordinates of a 2D sky projection and a 2D spectral wcs. +.le +.le +.ls transpose = no +Force a transpose of the reference image world coordinates before evaluating +the world to logical coordinate transformation for the input image ? This +option is useful if there is not enough information in the reference and +input image headers to tell whether or not the images are transposed with +respect to each other. +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate list containing the x and y coordinate +values if \fIcoords\fR = . +.le +.ls xunits = "", ls yunits = "" +The units of the x and y coordinates in the input coordinate list +if \fIcoords\fR = , by default decimal degrees for sky projection +coordinate systems, otherwise any units. +The options are: +.ls hours +Input coordinates specified in hours are converted to decimal degrees by +multiplying by 15.0. +.le +.ls native +The internal units of the wcs. No conversions on the input coordinates +are performed. +.le + +If the units are not specified the default is "native". +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls wxformat = "", wyformat = "" +The format of the output world x and y reference and input image coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for both sky projection coordinates +and other types, e.g. spectral coordinates. +.le +.ls min_sigdigits = 7 +The minimum precision of the output coordinates if, the formatting parameters +are undefined, or the output world coordinate system is "world" and the wcs +format attribute is undefined. +.le +.ls verbose = yes +Print messages about the progress of the task. +.le + +.ih +DESCRIPTION + +WCSXYMATCH matches the logical x and y pixel coordinates of a set of points +in the input image \fIinput\fR with the logical x and y pixels coordinates +of the same points in the reference image \fIreference\fR +using world coordinate information +in the respective image headers, and writes the results to a coordinate file +\fIoutput\fR suitable for input to the GEOMAP task. +The input and reference images may be 1D or 2D but must both have +the same dimensionality. + +If \fIcoords\fR = "grid", WCSXYMATCH computes a grid of \fInx * ny\fR +logical x and y pixel coordinates evenly distributed over the +logical pixel space of the reference image as defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The logical x and y pixel reference image coordinates are transformed to the +world coordinate system defined by \fIwcs\fR using +world coordinate information stored in the reference image header. +The world coordinates are then transformed back to the logical x and y pixel +input image coordinates, using world coordinate system information stored in +the input image header. + +If \fIcoords\fR is a file name, WCSXYMATCH reads a list of x and y +reference image world coordinates from columns \fIxcolumn\fR and \fIycolumn\fR +in the input coordinates file, and transforms these coordinates to +"native" coordinate units using the \fIxunits\fR and \fIyunits\fR parameters. +The reference image world coordinates are +transformed to logical reference and input image coordinates +using the value of the \fIwcs\fR parameter and world coordinate +information in the reference and input image headers. + +WCSXYMATCH will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the world coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the world <-> logical coordinate systems cannot be compiled for either +or both images, or the world coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image, +and defining an identify transformation, is written to the output file. + +The computed reference and input logical coordinates and the +world coordinates are written to the output file using +the \fIxformat\fR and \fIyformat\fR, and the \fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the world coordinates, a format attribute cannot be +read from either the reference or the input images, the coordinates are +output with the %g format and \fImin_sigdigits\fR of precision. + +If the reference and input images are 1D then the +output logical and world y coordinates are +set to 1. + +If \fIverbose\fR is "yes" then a title section is written to the output +file for each set of computed coordinates, along with messages about +what if anything went wrong with the computation. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be +found in the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system +interface MWCS can be found in the file "iraf$sys/mwcs/MWCS.hlp". +This file can be formatted and printed with the command "help +iraf$sys/mwcs/MWCS.hlp fi+ | lprint". Information on the spectral +coordinates systems and their suitability for use with WCSXYMATCH +can be obtained by typing "help specwcs | lprint". +Details of the FITS header +world coordinate system interface can be found in the document +"World Coordinate Systems Representations Within the FITS Format" +by Hanisch and Wells, available from our anonymous ftp archive. + +.ih +EXAMPLES + +1. Compute a matched list of 100 logical x and y coordinates for an X-ray +and radio image of the same field, both of which have accurate sky +projection world coordinate systems. Print the output world coordinates +in hh:mm:ss.ss and dd:mm:ss.s format + +.nf + cl> wcsxymatch image refimage coords wxformat=%12.2H \ + wyformat=%12.1h +.fi + +2. Given a list of ras and decs of objects in the reference image, +compute a list of matched logical x and y coordinates for the two images, +both of which have a accurate sky projection wcss. The ras and decs are in +columns 3 and 4 of the input coordinate file and are in hh:mm:ss.ss and +dd:mm:ss.s format respectively. Print the output world coordinates +in the same units as the input. + +.nf + cl> wcsxymatch image refimage coords coords=radecs \ + xcolumn=3 ycolumn=4 xunits=hours wxformat=%12.2H \ + wyformat=%12.1h +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +tprecess,wcstran,geomap,register,geotran,wcsmap,wregister +.endhelp diff --git a/pkg/images/immatch/doc/wregister.hlp b/pkg/images/immatch/doc/wregister.hlp new file mode 100644 index 00000000..e8519803 --- /dev/null +++ b/pkg/images/immatch/doc/wregister.hlp @@ -0,0 +1,761 @@ +.help wregister Dec98 images.immatch +.ih +NAME +wregister -- register a list of images to a reference image using WCS +information +.ih +USAGE +wregister input reference output +.ih +PARAMETERS +.ls input +The list of input images containing the input wcs. +.le +.ls reference +The list of reference images containing the reference wcs. The number of +reference images must be one or equal to the number of input images. +.le +.ls output +The list of output registered images. The number of output images must +be equal to the number of input images. +.le +.ls xmin = INDEF, xmax = INDEF, ymin = INDEF, ymax = INDEF +The minimum and maximum logical x and logical y coordinates used to, generate +the grid of reference image control points, define the region of validity of +the spatial transformation, and define the extent of the output image. +Xmin, xmax, ymin, and +ymax are assigned defaults of 1, the number of columns in the reference +image, 1, and the number of lines in the reference image, respectively. +.le +.ls nx = 10, ny = 10 +The number of points in x and y used to generate the coordinate grid. +.le +.ls wcs = "world" +The world coordinate system of the coordinates. The options are: +.ls physical +Physical coordinates are pixel coordinates which are invariant with +respect to linear transformations of the physical image data. For example, +if the reference +image is a rotated section of a larger input image, the physical +coordinates of an object in the reference image are equal to the physical +coordinates of the same object in the input image, although the logical +pixel coordinates are different. +.le +.ls world +World coordinates are image coordinates which are invariant with +respect to linear transformations of the physical image data and which +are in world units, normally decimal degrees for sky projection coordinate +systems and angstroms for spectral coordinate systems. Obviously if the +wcs is correct the ra and dec or wavelength and position of an object +should remain the same not matter how the image +is linearly transformed. The default world coordinate +system is either 1) the value of the environment variable "defwcs" if +set in the user's IRAF environment (normally it is undefined) and present +in the image header, 2) the value of the "system" +attribute in the image header keyword WAT0_001 if present in the +image header or, 3) the "physical" coordinate system. +Care must be taken that the wcs of the input and +reference images are compatible, e.g. it makes no sense to +match the coordinates of a 2D sky projection and a 2D spectral wcs. +.le +.le +.ls transpose = no +Force a transpose of the reference image world coordinates before evaluating +the world to logical coordinate transformation for the input image ? This +option is useful if there is not enough information in the reference and +input image headers to tell whether or not the images are transposed with +respect to each other. +.le +.ls xformat = "%10.3f", yformat = "%10.3f" +The format of the output logical x and y reference and input pixel +coordinates in columns 1 and 2 and 3 and 4 respectively. By default the +coordinates are output right justified in a field of ten spaces with +3 digits following the decimal point. +.le +.ls wxformat = "", wyformat = "" +The format of the output world x and y reference and input image coordinates +in columns 5 and 6 respectively. The internal default formats will give +reasonable output formats and precision for both sky projection coordinates +and other, e.g. spectral, coordinates. +.le +.ls fitgeometry = "general" +The fitting geometry to be used. The options are the following. +.ls shift +X and y shifts only are fit. +.le +.ls xyscale +X and y shifts and x and y magnification factors are fit. Axis flips are +allowed for. +.le +.ls rotate +X and y shifts and a rotation angle are fit. Axis flips are allowed for. +.le +.ls rscale +X and y shifts, a magnification factor assumed to be the same in x and y, and a +rotation angle are fit. Axis flips are allowed for. +.le +.ls rxyscale +X and y shifts, x and y magnifications factors, and a rotation angle are fit. +Axis flips are allowed for. +.le +.ls general +A polynomial of arbitrary order in x and y is fit. A linear term and a +distortion term are computed separately. The linear term includes an x and y +shift, an x and y scale factor, a rotation and a skew. Axis flips are also +allowed for in the linear portion of the fit. The distortion term consists +of a polynomial fit to the residuals of the linear term. By default the +distortion terms is set to zero. +.le + +For all the fitting geometries except "general" no distortion term is fit, +i.e. the x and y polynomial orders are assumed to be 2 and the cross term +switches are set to "none", regardless of the values of the \fIxxorder\fR, +\fIxyorder\fR, \fIxxterms\fR, \fIyxorder\fR, \fIyyorder\fR and \fIyxterms\fR +parameters set by the user. +.le +.ls function = "polynomial" +The type of analytic coordinate surfaces to be fit. The options are the +following: +.ls legendre +Legendre polynomials in x and y. +.le +.ls chebyshev +Chebyshev polynomials in x and y. +.le +.ls polynomial +Power series polynomials in x and y. +.le +.le +.ls xxorder = 2, xyorder = 2, yxorder = 2, yyorder = 2 +The order of the polynomials in x and y for the x and y fits respectively. +The default order and cross term settings define the linear term in x +and y, where the 6 coefficients can be interpreted in terms of an x and y shift, +an x and y scale change, and rotations of the x and y axes. The "shift", +"xyscale", "rotation", "rscale", and "rxyscale", fitting geometries +assume that the polynomial order parameters are 2 regardless of the values +set by the user. If any of the order parameters are higher than 2 and +\fIfitgeometry\fR is "general", then a distortion surface is fit to the +residuals from the linear portion of the fit. +.le +.ls xxterms = "half", yxterms = "half" +The options are: +.ls none +The individual polynomial terms contain powers of x or powers of y but not +powers of both. +.le +.ls half +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1, xyorder - 1) for the x fit and +MAX (yxorder - 1, yyorder - 1) for the y fit. +.le +.ls full +The individual polynomial terms contain powers of x and powers of y, whose +maximum combined power is MAX (xxorder - 1 + xyorder - 1) for the x fit and +MAX (yxorder - 1 + yyorder - 1) for the y fit. +.le + +The "shift", "xyscale", "rotation", "rscale", and "rxyscale" fitting +geometries, assume that the cross term switches are set to "none"regardless +of the values set by the user. If either of the cross terms parameters is +set to "half" or "full" and \fIfitgeometry\fR is "general" then a distortion +surface is fit to the residuals from the linear portion of the fit. +.le +.ls reject = INDEF +The rejection limit in units of sigma. The default is no rejection. +.le +.ls calctype = "real" +The precision of coordinate transformation calculations. The options are "real" +and "double". +.le +.ls geometry = "geometric" +The type of geometric transformation. The options are: +.ls linear +Perform only the linear part of the geometric transformation. +.le +.ls geometric +Compute both the linear and distortion portions of the geometric correction. +.le +.le +.ls xsample = 1.0, ysample = 1.0 +The coordinate surface subsampling factor. The coordinate surfaces are +evaluated at every xsample-th pixel in x and every ysample-th pixel in y. +Transformed coordinates at intermediate pixel values are determined by +bilinear interpolation in the coordinate surfaces. If the coordinate +surface is of high order setting these numbers to some reasonably high +value is recommended. +.le +.ls interpolant = "linear" +The interpolant used for rebinning the image. The choices are the following. +.ls nearest +Nearest neighbor. +.le +.ls linear +Bilinear interpolation in x and y. +.le +.ls poly3 +Third order polynomial in x and y. +.le +.ls poly5 +Fifth order polynomial in x and y. +.le +.ls spline3 +Bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width will be rounded up to +the nearest odd number. The default sinc width is 31 by 31. +.le +.ls lsinc +Look-up table sinc interpolation. Users can specify the look-up table sinc +interpolant width by appending a width value to the interpolant string, e.g. +lsinc51 specifies a 51 by 51 pixel wide look-up table sinc interpolant. The user +supplied sinc width will be rounded up to the nearest odd number. The default +sinc width is 31 by 31 pixels. Users can specify the resolution of the lookup +table sinc by appending the look-up table size in square brackets to the +interpolant string, e.g. lsinc51[20] specifies a 20 by 20 element sinc +look-up table interpolant with a pixel resolution of 0.05 pixels in x and y. +The default look-up table size and resolution are 20 by 20 and 0.05 pixels +in x and y respectively. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fraction in x and y +by appending a value between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. +The value 0.0 is increased internally to 0.001. Drizzle resampling +with a pixel fraction of 1.0 in x and y is equivalent to fractional pixel +rotated block summing (fluxconserve = yes) or averaging (flux_conserve = no) if +xmag and ymag are > 1.0. +.le +.le +.ls boundary = "nearest" +The choices are: +.ls nearest +Use the value of the nearest boundary pixel. +.le +.ls constant +Use a user supplied constant value. +.le +.ls reflect +Generate a value by reflecting about the boundary of the image. +.le +.ls wrap +Generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0.0 +The value of the constant for boundary extension. +.le +.ls fluxconserve = yes +Preserve the total image flux? If flux conservation is turned on, the output +pixel values are multiplied by the Jacobian of the coordinate transformation. +.le +.ls nxblock = 512, nyblock = 512 +If the size of the output image is less than nxblock by nyblock then the +entire image is computed in one iteration. Otherwise the output image is +computed in blocks of nxblock by nyblock pixels. +.le +.ls wcsinherit = yes +Inherit the wcs of the reference image ? +.le +.ls verbose = yes +Print messages about the progress of the task? +.le +.ls interactive = no +Run the task interactively ? +In interactive mode the user may interact with the fitting process, e.g. +change the order of the fit, delete points, replot the data etc. +.le +.ls graphics = "stdgraph" +The graphics device. +.le +.ls gcommands = "" +The graphics cursor. +.le + +.ih +DESCRIPTION + +WREGISTER computes the spatial transformation function required to register +the input image \fIinput\fR to the reference image \fIreference\fR, +and writes the registered input image to the output image \fIoutput\fR. +The input and reference images must be one- or two-dimensional and +have the same dimensionality. WREGISTER assumes that the world +coordinate systems in the input and reference +image headers are accurate and that the two systems are compatible, e.g. both +images have the same epoch sky projection world coordinate systems, or both are +spectra whose coordinates are in the same units. + +WREGISTER computes the required spatial transformation by matching the logical +x and y pixel coordinates of a grid of points +in the input image with the logical x and y pixels coordinates +of the same grid of points in the reference image, +using world coordinate information stored in the two image headers. +The coordinate grid consists of \fInx * ny\fR points evenly distributed +over the logical pixel space of interest in the reference image defined by the +\fIxmin\fR, \fIxmax\fR, \fIymin\fR, \fIymax\fR parameters. +The logical x and y pixel reference image coordinates are transformed to the +reference image world coordinate system defined by \fIwcs\fR, using the wcs +information in the reference image header. +The reference image world coordinates are then transformed to logical x and +y pixel coordinates in the input image, using world coordinate system +information stored in the input image header. + +The computed reference and input logical coordinates and the +world coordinates are written to a temporary coordinates file which is +deleted on task termination. +The x and y coordinates are written using +the \fIxformat\fR and \fIyformat\fR and the \fIwxformat\fR and \fIwxformat\fR +parameters respectively. If these formats are undefined and, in the +case of the world coordinates a format attribute cannot be +read from either the reference or the input images, the coordinates are +output in %g format with \fImin_sigdigits\fR digits of precision. +If the reference and input images are 1D then all the output logical and +world y coordinates are set to 1. + +WREGISTER computes a spatial transformation of the following form. + +.nf + xin = f (xref, yref) + yin = g (xref, yref) +.fi + +The functions f and g are either a power series polynomial or a Legendre or +Chebyshev polynomial surface of order +\fIxxorder\fR and \fIxyorder\fR in x and \fIyxorder\fR and \fIyyorder\fR in y. + +Several polynomial cross terms options are available. Options "none", +"half", and "full" are illustrated below for a quadratic polynomial in +x and y. + +.nf +xxterms = "none", xyterms = "none" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a13' * yref ** 2 + +xxterms = "half", xyterms = "half" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a12 * yref + + a31 * xref ** 2 + a22 * xref * yref + a13 * yref ** 2 + yin = a11' + a21' * xref + a12' * yref + + a31' * xref ** 2 + a22' * xref * yref + a13' * yref ** 2 + +xxterms = "full", xyterms = "full" +xxorder = 3, xyorder = 3, yxorder = 3, yyorder = 3 + + xin = a11 + a21 * xref + a31 * xref ** 2 + + a12 * yref + a22 * xref * yref + a32 * xref ** 2 * yref + + a13 * yref ** 2 + a23 * xref * yref ** 2 + + a33 * xref ** 2 * yref ** 2 + yin = a11' + a21' * xref + a31' * xref ** 2 + + a12' * yref + a22' * xref * yref + a32' * xref ** 2 * yref + + a13' * yref ** 2 + a23' * xref * yref ** 2 + + a33' * xref ** 2 * yref ** 2 +.fi + + +If the \fBfitgeometry\fR parameter is anything other than "general", the order +parameters assume the value 2 and the cross terms switches assume the value +"none", regardless of the values set by the user. The computation can be done in +either real or double precision by setting the \fIcalctype\fR parameter. +Automatic pixel rejection may be enabled by setting the \fIreject\fR +parameter to some number > 0.0. + +The transformation computed by the "general" fitting geometry is arbitrary +and does not correspond to a physically meaningful model. However the computed +coefficients for the linear term can be given a simple geometrical geometric +interpretation for all the fitting geometries as shown below. + +.nf + fitting geometry = general (linear term) + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + + fitting geometry = shift + xin = a + xref + yin = d + yref + + fitting geometry = xyscale + xin = a + b * xref + yin = d + f * yref + + fitting geometry = rotate + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/-1 + b = f, c = -e or b = -f, c = e + + fitting geometry = rscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const + b = f, c = -e or b = -f, c = e + + fitting geometry = rxyscale + xin = a + b * xref + c * yref + yin = d + e * xref + f * yref + b * f - c * e = +/- const +.fi + + +The coefficients can be interpreted as follows. Xref0, yref0, xin0, yin0 +are the origins in the reference and input frames respectively. Orientation +and skew are the orientation of the x and y axes and their deviation from +perpendicularity respectively. Xmag and ymag are the scaling factors in x and +y and are assumed to be positive. + +.nf + general (linear term) + xrotation = rotation - skew / 2 + yrotation = rotation + skew / 2 + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + shift + xrotation = 0.0, yrotation = 0.0 + xmag = ymag = 1.0 + b = 1.0 + c = 0.0 + e = 0.0 + f = 1.0 + a = xin0 - xref0 = xshift + d = yin0 - yref0 = yshift + + xyscale + xrotation 0.0 / 180.0 yrotation = 0.0 + b = + /- xmag + c = 0.0 + e = 0.0 + f = ymag + a = xin0 - b * xref0 = xshift + d = yin0 - f * yref0 = yshift + + rscale + xrotation = rotation + 0 / 180, yrotation = rotation + mag = xmag = ymag + const = mag * mag + b = mag * cos (xrotation) + c = mag * sin (yrotation) + e = -mag * sin (xrotation) + f = mag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift + + rxyscale + xrotation = rotation + 0 / 180, yrotation = rotation + const = xmag * ymag + b = xmag * cos (xrotation) + c = ymag * sin (yrotation) + e = -xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xin0 - b * xref0 - c * yref0 = xshift + d = yin0 - e * xref0 - f * yref0 = yshift +.fi + + +\fIXmin\fR, \fIxmax\fR, \fIymin\fR and \fIymax\fR define the region of +validity of the transformation as well as the limits of the grid +in the reference coordinate system. + +Each computed transformation is written to a temporary output text database +file which is deleted on task termination. If more that one record of the same +name is written to the database file, the last record written is the +valid record. + +WREGISTER will terminate with an error if the reference and input images +are not both either 1D or 2D. +If the world coordinate system information cannot be read from either +the reference or input image header, the requested transformations +from the world <-> logical coordinate systems cannot be compiled for either +or both images, or the world coordinate systems of the reference and input +images are fundamentally incompatible in some way, the output logical +reference and input image coordinates are both set to a grid of points +spanning the logical pixel space of the input, not the reference image. +This grid of points defines an identity transformation which results in +an output image equal to the input image. + +WREGISTER computes the output image by evaluating the fitted coordinate +surfaces and interpolating in the input image at position of the transformed +coordinates. The scale of the output image is the same as the scale of the +reference image. The extent and size of the output image are determined +by the \fIxmin\fR, \fIxmax\fR, \fIymin\fR, and \fIymax\fR parameters +as shown below + +.nf + xmin <= x <= xmax + ymin <= x <= ymax + ncols = xmax - xmin + 1 + nlines = xmax - xmin + 1 +.fi + +WREGISTER samples the coordinate surfaces at every \fIxsample\fR and +fIysample\fR pixels in x and y. +The transformed coordinates at intermediate pixel values are +determined by bilinear interpolation in the coordinate surface. If +\fIxsample\fR and \fIysample\fR = 1, the coordinate +surface is evaluated at every pixel. Use of \fIxsample\fR and \fIysample\fR +are strongly recommended for large images and high order coordinate +surfaces in order to reduce the time required to compute the output image. + +The output image gray levels are determined by interpolating in the input +image at the positions of the transformed output pixels using the +interpolant specified by the \fIinterpolant\fR parameter. If the +\fIfluxconserve\fR switch is set the output pixel values are multiplied by +the Jacobian of the transformation, which preserves the flux of the entire +image. Out-of-bounds pixels are evaluated using the \fIboundary\fR and +\fIconstant\fR parameters. + +The output image is computed in \fInxblock\fR by \fInyblock\fR pixel sections. +If possible users should set these number to values larger than the dimensions +of the output image to minimize the number of disk reads and writes required +to compute the output image. If this is not feasible and the image rotation is +small users should set nxblock to be greater than the number of columns in +the output image, and nyblock to be as large as machine memory will permit. + +If \fIwcsinherit\fR is "yes" then the world coordinate system of the +reference image will be copied to the output image. +Otherwise if the environment variable \fInomwcs\fR is "no" the +world coordinate +system of the input image is modified in the output image to reflect the +effects of the \fIlinear\fR portion of the registration operation. +Support does not yet exist in the IRAF world coordinate system interface +for the higher order distortion corrections that WREGISTER is capable +of performing. + +If \fIverbose\fR is "yes" then messages about the progress of the task +as well as warning messages indicating potential problems +are written to the standard output. + +WREGISTER may be run interactively by setting the \fIinteractive\fR +parameter to "yes". +In interactive mode the user has the option of viewing the fitted +spatial transformation, changing the +fit parameters, deleting and undeleting points, and replotting +the data until a satisfactory +fit has been achieved. + +.ih +CURSOR COMMANDS + +In interactive mode the following cursor commands are currently available. + +.nf + Interactive Keystroke Commands + +? Print options +f Fit the data and graph with the current graph type (g, x, r, y, s) +g Graph the data and the current fit +x,r Graph the x fit residuals versus x and y respectively +y,s Graph the y fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the constant x, y plotting option +t Plot a line of constant x, y through the nearest data point +l Print xshift, yshift, xmag, ymag, xrotate, yrotate +q Exit the interactive curve fitting +.fi + +The parameters listed below can be changed interactively with simple colon +commands. Typing the parameter name alone will list the current value. + +.nf + Colon Parameter Editing Commands + +:show List parameters +:fitgeometry Fitting geometry (shift,xyscale,rotate, + rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre, + polynomial) +:xxorder :xyorder [value] X fitting function xorder, yorder +:yxorder :yyorder [value] Y fitting function xorder, yorder +:xxterms :yxterms [nh/f] X, Y fit cross terms fit +:reject [value] Rejection threshold +.fi + + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +Additional information on IRAF world coordinate systems including +more detailed descriptions of the "logical", "physical", and "world" +coordinate systems can be +found in the help pages for the WCSEDIT and WCRESET tasks. +Detailed documentation for the IRAF world coordinate system +interface MWCS can be found in the file "iraf$sys/mwcs/MWCS.hlp". +This file can be formatted and printed with the command "help +iraf$sys/mwcs/MWCS.hlp fi+ | lprint". Information on the spectral +coordinates systems and their suitability for use with WCSXYMATCH +can be obtained by typing "help specwcs | lprint". +Details of the FITS header +world coordinate system interface can be found in the document +"World Coordinate Systems Representations Within the FITS Format" +by Hanisch and Wells, available from our anonymous ftp archive. + +.ih +EXAMPLES + +1. Register a radio image to an X-ray image of the same field using +a 100 point coordinate grid and a simple linear transformation. Both +images have accurate sky projection world coordinate systems. Print the +output world coordinates in the coords file in hh:mm:ss.ss and dd:mm:ss.s +format. Display the input and output image and blink them. + +.nf + cl> wregister radio xray radio.tran wxformat=%12.2H \ + wyformat=%12.1h + + cl> display radio 1 fi+ + + cl> display radio.tran 2 fi+ +.fi + +2. Repeat the previous command but begin with a higher order fit +and run the task in interactive mode in order to examine the fit +residuals. + +.nf + cl> wregister radio xray radio.tran wxformat=%12.2H \ + wyformat=%12.1h xxo=4 xyo=4 xxt=half yxo=4 yyo=4 \ + yxt=half inter+ + + ... a plot of the fit appears + + ... type x and r to examine the residuals of the x + surface fit versus x and y + + ... type y and s to examine the residuals of the y + surface fit versus x and y + + ... delete 2 deviant points with the d key and + recompute the fit with the f key + + ... type q to quit, save the fit, and compute the registered + image +.fi + +3. Mosaic a set of 9 images covering a ~ 1 degree field into a single image +centered at 12:32:53.1 +43:13:03. Set the output image scale to 0.5 +arc-seconds / pixel which is close the detector scale of 0.51 arc-seconds +per pixel. Set the orientation to be north up and east to the left. +The 9 images all have accurate world coordinate information in their headers. + +.nf + # Create a dummy reference image big enough to cover 1 square degree + + cl> mkpattern refimage ncols=7200 nlines=7200 ... + + # Give the dummy reference image the desired coordinate system + + cl> ccsetwcs refimage "" xref=3600.5 yref=3600.5 xmag=-0.5 \ + ymag=0.5 lngref=12:32:53.1 latref=43:13:03 ... + + # Register the images using constant boundary extension and + # set uservalue to some reasonable value outside the good data + # range. Note that it may be possible to improve performance by + #increasing nxblock and nyblock. + + cl> wregister @inlist refimage @outlist boundary=constant \ + constant= nxblock=7200 nyblock=1024 ... + + # Combine the images using imcombine + + cl> imcombine @outlist mosaic lthreshold= ... + +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imalign,xregister,tprecess,wcsxymatch,geomap,gregister,geotran,wcscopy +.endhelp diff --git a/pkg/images/immatch/doc/xregister.hlp b/pkg/images/immatch/doc/xregister.hlp new file mode 100644 index 00000000..b0690118 --- /dev/null +++ b/pkg/images/immatch/doc/xregister.hlp @@ -0,0 +1,707 @@ +.help xregister Dec98 images.immatch +.ih +NAME +xregister -- register 1 and 2D images using X-correlation techniques +.ih +USAGE +xregister input reference regions shifts +.ih +PARAMETERS +.ls input +The list of input images to be registered. +.le +.ls reference +The list of reference images to which the input images are to be registered. +The number of reference images must be one or equal to the number of input +images. +.le +.ls regions +The list of reference image region(s) used to compute the +x and y shifts. +\fIRegions\fR may be: 1) a list of one or more image sections +separated by whitespace, 2) the name of a text file containing a list +of one or more image sections separated by whitespace and/or newlines, +3) a string of the form "grid nx ny" defining a grid of nx by ny +equally spaced and sized image sections spanning the entire image. Shifts are +computed for each specified region individually and averaged to produce the +final x and y shift. +.le +.ls shifts +The name of the text file where the computed x and y shifts +are written. If \fIdatabasefmt\fR is "yes", a single record containing the +computed x and y shifts for each image region and the final average x and y +shift is written to a text database file for each input image. +If \fIdatabasefmt\fR = "no", a single line containing the image name and the +final average x and y shift is written to a simple text file +for each input image. +.le +.ls output = "" +The list of output shifted images. If \fIoutput\fR is the NULL string +then x and y shifts are computed for each input image and written to +\fIshifts\fR but no output images are written. If \fIoutput\fR is not NULL +then the number of output images must equal the number of input images. +.le +.ls databasefmt = yes +If \fIdatabasefmt\fR is "yes" the results are written to a text database +file, otherwise they are written to a simple text file. +.le +.ls records = "" +The list of records to be written to or read from \fIshifts\fR for each +input image. If \fIrecords\fR is NULL then the output or input record names +are assumed to be the names of the input images. If \fIrecords\fR is not NULL +then the record names in \fIrecords\fR are used to write / read the +records. This parameter is useful for users +who, wish to compute the x and y shifts using images that have been processed +in some manner (e.g. smoothed), but apply the computed x and y shifts to the +original unprocessed images. If more then one record +with the same name exists in \fIshifts\fR then the most recently written +record takes precedence. The records parameter is ignored if +\fIdatabasefmt\fR is "no". +.le +.ls append = yes +Append new records to an existing \fIshifts\fR file or start a new shifts +file for each execution of XREGISTER? The append parameter is ignored +if \fIdatabasefmt\fR is "no". +.le +.ls coords = "" +An optional list of coordinates files containing the x and y coordinates of +an object in the reference image on the first line and the x and y coordinates +of the same object in the input image(s) on succeeding lines. The number +of coordinate files must be equal to the number of reference images. +The input coordinates are used to compute initial +values for the x and y lags between the input image and the reference image, +and supersede any non-zero values of \fIxlag\fR, \fIylag\fR, \fIdxlag\fR, +and \fIdylag\fR supplied by the user. +.le +.ls xlag = 0, ylag = 0 +The initial x and y lags of the input image with respect to the reference +image. Positive values imply that the input image is shifted +in the direction of increasing x and y values with respect to the +reference image. \fIXlag\fR and \fIylag\fR are overridden if an offset +has been determined using the x and y coordinates in the \fIcoords\fR file. +.le +.ls dxlag = 0, dylag = 0 +The increment in \fIxlag\fR and \fIylag\fR to be applied to successive input +images. If \fIdxlag\fR and \fIdylag\fR are set to INDEF then the +computed x and y lags for the previous image are used as the initial +x and y lags for the current image. This option is useful for images which +were taken as a time sequence and whose x and y the shifts increase or +decrease in a systematic manner. +\fIDxlag\fR and \fIdylag\fR are overridden if an offset +has been determined using x and y coordinates in the \fIcoords\fR file. +.le +.ls background = none +The default background function to be subtracted from the input +and reference image data in each region before the +cross-correlation function is computed. The options are: +.ls none +no background subtraction is done. +.le +.ls mean +the mean of the reference and input image region is computed and subtracted +from the image data. +.le +.ls median +the median of the reference and input image region is computed and subtracted +from the data. +.le +.ls plane +a plane is fit to the reference and input image region and subtracted +from the data. +.le + +By default the cross-correlation function is computed in a manner +which removes the mean intensity in the reference and input image regions +from the data. For many data sets this "correction" is sufficient to +remove first order background level effects +from the computed cross-correlation function and no additional +background subtraction is required. +.le +.ls border = INDEF +The width of the border region around the input and reference image data +regions used to compute the background function if \fIbackground\fR +is not "none". By default the entire region is used. +.le +.ls loreject = INDEF, ls hireject = INDEF +The k-sigma rejection limits for removing the effects of bad data from the +background fit. +.le +.ls apodize = 0.0 +The fraction of the input and reference image data endpoints in x and y +to apodize with a +cosine bell function before the cross-correlation function is computed. +.le +.ls filter = none +The spatial filter to be applied to the reference and input image +data before the cross-correlation function is computed. The options are: +.ls none +no spatial filtering is performed. +.le +.ls laplace +a Laplacian filter is applied to the reference and input image data. +.le +.le +.ls correlation = discrete +The algorithm used to compute the cross-correlation function. The options +are: +.ls discrete +The cross-correlation function is calculated by computing the discrete +convolution of the reference and input image regions over the x and y +window of interest. This technique is most efficient method for small +cross-correlation function x and y search windows. +.le +.ls fourier +The cross-correlation function is calculated by computing the convolution +of the reference and input image regions using Fourier techniques. +This technique is the most efficient method for computing the +cross-correlation function for small x and y search windows. +.le +.ls difference +The cross-correlation function is calculated by computing the error +function of the reference and input images as a function of position +in the x and y search window. +.le +.ls file +No cross-correlation function is computed. Instead the previously +computed x and y shifts are read from record \fIrecord\fR in the text +database file \fIshifts\fR if \fIdatabasefmt\fR is "yes", or the +next line of a simple text file if \fIdatabasefmt\fR is "no". +.le +.le +.ls xwindow = 11, ywindow = 11 +The x and y width of the cross-correlation function region +to be computed and/or searched for peaks. The search window corresponds +to shifts of - xwindow / 2 <= xshift <= xwindow /2 and - ywindow / 2 <= +yshift <= ywindow / 2. \fIXwindow\fR and \fIywindow\fR +are automatically rounded up to the next nearest odd number. +.le +.ls function = centroid +The algorithm used to compute the x and y position of the cross-correlation +function peak. The options are: +.ls none +the position of the cross-correlation function peak is set to +x and y position of the maximum pixel. +.le +.ls centroid +the position of the cross-correlation function peak is calculated +by computing the intensity-weighted mean of the marginal profiles of +the cross-correlation function in x and y. +.le +.ls sawtooth +the position of the cross-correlation function peak is calculated +by convolving 1D slices in x and y through the cross-correlation function +with a 1D sawtooth function and using the point at which the peak is +bisected to determine the x and y position of the cross-correlation +peak. +.le +.ls parabolic +a 1D parabola is fit to 1D slices in x and y through the cross-correlation +function and the fitted coefficients are used to compute the peak of +the cross-correlation function. +.le +.ls mark +mark the peak of the cross-correlation function with the graphics cursor. +This option will only work if \fIinteractive\fR = "yes". +.le +.le +.ls xcbox = 5, ycbox = 5 +The width of the box centered on the peak of the cross-correlation function +used to compute the fractional pixel x and y center. +.le +.ls interp_type = "linear" +The interpolant type use to computed the output shifted image. +The choices are the following: +.ls nearest +nearest neighbor. +.le +.ls linear +bilinear interpolation in x and y. +.le +.ls poly3 +third order interior polynomial in x and y. +.le +.ls poly5 +fifth order interior polynomial in x and y. +.le +.ls spline3 +bicubic spline. +.le +.ls sinc +2D sinc interpolation. Users can specify the sinc interpolant width by +appending a width value to the interpolant string, e.g. sinc51 specifies +a 51 by 51 pixel wide sinc interpolant. The sinc width input by the +user will be rounded up to the nearest odd number. The default sinc width +is 31 by 31. +.le +.ls drizzle +2D drizzle resampling. Users can specify the drizzle pixel fractions in x and y +by appending values between 0.0 and 1.0 in square brackets to the +interpolant string, e.g. drizzle[0.5]. The default value is 1.0. The +value 0.0 is increased to 0.001. Drizzle resampling with a pixel fraction +of 1.0 in x and y is identical to bilinear interpolation. +.le +.le +.ls boundary_type = "nearest" +The boundary extension algorithm used to compute the output shifted +image. The choices are: +.ls nearest +use the value of the nearest boundary pixel. +.le +.ls constant +use a constant value. +.le +.ls reflect +generate a value by reflecting about the boundary. +.le +.ls wrap +generate a value by wrapping around to the opposite side of the image. +.le +.le +.ls constant = 0 +The default constant for constant boundary extension. +.le +.ls interactive = no +Compute the cross-correlation function and the shifts for each image +interactively using graphics cursor and optionally image cursor input. +.le +.ls verbose +Print messages about the progress of the task during task execution +in non-interactive mode. +.le +.ls graphics = "stdgraph" +The default graphics device. +.le +.ls display = "stdimage" +The default image display device. +.le +.ls gcommands = "" +The default graphics cursor. +.le +.ls icommands = "" +The default image display cursor. +.le + +.ih +DESCRIPTION + +XREGISTER computes the x and y shifts required to register a list of input +images \fIinput\fR to a list of reference images \fIreference\fR using +cross-correlation techniques. The computed x and y shifts are stored +in the text file \fIshifts\fR, in the records \fIrecords\fR if +\fIdatabasefmt\fR is "yes" or a single line of a simple text file +if \fIdatabasefmt\fR is "no". One entry is made in the shifts file for +each input image. If a non NULL list of output images +\fIoutput\fR is supplied a shifted output image is written for each input +image. XREGISTER is intended to solve 1D and 2D image registration problems +where the images have the same size, the same pixel scale, are shifted +relative to +each other by simple translations in x and y, and contain one or more +extended features in common that will produce a peak in the computed +cross-correlation function. + +The reference image regions used to compute the cross-correlation +function shifts are defined by the parameter +\fIregions\fR. \fIRegions\fR may be: +1) a list of one or more image sections, e.g. +"[100:200,100:200] [400:500,400:500]" separated +by whitespace, 2) the name of a text file containing a list of one or +more image sections separated by whitespace and / or newline characters, +or, 3) a string +of the form "grid nx ny" specifying a grid of nx by ny +image sections spanning the entire reference image. +All reference image regions should be chosen so as to +include at least one well-defined object or feature. Cross-correlation +functions and x and y shifts are computed independently for each +reference image region +and averaged to produce the final x and y shift for each input image. + +By default the initial x and y lags between the input and reference +image are assumed to by 0.0 and 0.0 +respectively and each reference image region is cross-correlated +with the identical region in the input image, e.g reference image +region [100:200,100:200] is cross-correlated with input image +region [100:200,100:200]. + +Non-zero initial guesses for +the x and y shifts for each input image can be input to XREGISTER using +the coordinates file parameter \fIcoords\fR. +\fICoords\fR is a simple text file containing the x +and y coordinates of a single +object in the reference image in columns one and two +of line one, and the x and y coordinates of the same object in the first +input image in columns one and two of line two, etc. If \fIcoords\fR +is defined there must be one coordinate file for every reference image. +If there are fewer lines of text in \fIcoords\fR than there are +numbers of reference plus input images, then x and y shifts of 0.0 are +assumed for the extra input images. For example, +if the user specifies a single input and reference image, sets the +\fIregions\fR parameter to "[100:200,100:200]", and defines +a coordinates file which contains the numbers +50.0 50.0 in columns one and two of line one, and the numbers 52.0 and 52.0 +in columns one and two of line two, then the initial x and y +lags for the input image with respect to the reference image will be 2.0 +and 2.0 respectively, and the reference image region [100:200,100:200] will be +cross-correlated with the input image region [102:202,102:202]. + +If \fIcoords\fR is NULL, the parameters \fIxlag\fR, \fIylag\fR, +\fIdxlag\fR, and \fIdylag\fR can be used to define initial x and y lags +for each input image. \fIXlag\fR and \fIylag\fR define the x and y lags +of the first input image with respect to the reference image. In the +example above they would be set to 2.0 and 2.0 respectively. Initial +shifts for succeeding images are computed by adding the values of the +\fIdxlag\fR and \fIdylag\fR parameters to the values of +\fIxlag\fR and \fIylag\fR assumed for the previous image. +If \fIdxlag\fR and \fIdylag\fR are 0.0 and 0.0 +the same initial x and y lag will be used for all the input +images. If \fIdxlag\fR and \fIdylag\fR are both finite numbers then these +numbers will be added to +the x and y lags assumed for the previous image. If these numbers +are both INDEF then the computed x and y lags for the previous image +will be used to compute the initial x and y lags for the current image. +Both options can be useful for time series images where the x and y +shifts between successive images display some regular behavior. + +Prior to computing the cross-correlation function +large mean background values and gradients should be removed +from the input and reference image data as either +can seriously degrade the peak of the cross-correlation +function. To first order XREGISTER computes the cross-correlation function +in a manner which removes +the effect of large mean background values from the resulting +function. For many if not most typical data sets the user can safely leave +the parameter \fIbackground\fR at its default value of "none" and +achieve reasonable results. For more demanding data sets the user should +experiment with the "mean", "median", and "plane" background fitting +algorithms which compute and subtract, the mean value, median value, and +a plane from the input and reference image data respectively, +before computing the +cross-correlation function. The region used to compute the background fitting +function can be restricted to a border around the reference and +input image regions by setting the \fIborder\fR parameter. Bad +data can be rejected from the background fit by setting the \fIloreject\fR +and \fIhireject\fR parameters. + +A cosine bell function can be applied to the edges of the input and +reference image data before +computing the cross-correlation function by setting the \fIapodize\fR +parameter. + +If the \fIfilter\fR parameter is set to "laplace" instead of its default +value of "none" then a Laplacian filter is applied to the input and +reference image data before the cross-correlation function is computed. +This spatial filtering operation effectively +removes both a background and a slope from the input and reference image +data and +highlights regions of the image where the intensity is changing rapidly. +The effectiveness of this filtering operation in sharpening the +correlation peak depends on the degree to +which the intensity in adjacent pixels is correlated. + +The cross-correlation function for each region is computed by +discrete convolution, \fIcorrelation\fR = "discrete", +Fourier convolution, \fIcorrelation\fR = "fourier", or by computing +the error function, \fIcorrelation\fR = "difference". The x and y lag +space in pixels around the initial x and y lag over which the cross-correlation +function is searched for the correlation peak, is specified by the +\fIxwindow\fR and +\fIywindow\fR parameters. These parameter define a range of x and y lags from +-xwindow / 2 to xwindow / 2 and -ywindow / 2 to ywindow / 2 respectively. For +a given input and reference image region, the +execution time of XREGISTER will depend strongly on both the correlation +algorithm chosen and +the size of the search window. In general users should use discrete +or difference correlation for small search windows and fourier +correlation for large search windows. + +The x and y lags for each input and reference image +region are computed by computing +the position of the peak of the cross-correlation function in the +search window using +one of the four centering algorithms: "none", "centroid", "sawtooth", +and "parabolic". + +The computed x and y shifts for each region and the final x and y shift +for each input image (where the computed x and y shifts are just the negative +of the computed x and y lags) are written to the shifts file \fIshifts\fR. +If \fIdatabasefmt\fR is "yes" each results is written in a record whose name +is either identical to the name of the input +image or supplied by the user via the \fIrecords\fR parameter . +If \fIdatabasefmt\fR is "no", then a single containing the input image +name and the computed x and y shifts is written to the output shifts file. + +If a list of output image names have been supplied then the x and y +shifts will be applied to the input images to compute the output images +using the interpolant type specified by \fIinterp_type\fR and the +boundary extension algorithm specified by \fIboundary\fR and \fIconstant\fR. + +If the \fIcorrelation\fR parameter is set to "file" then the shifts +computed in a previous run of XREGISTER will be read from the \fIshifts\fR +file and applied to the input images to compute the output images. +If no record list is supplied by the user XREGISTER will for each input +image search for +a record whose name is the same as the input image name. If more than +one record of the same name is found then the most recently written +record will be used. + +XREGISTER does not currently trim the input images but it computes and +prints the region over which they all overlap in the form of an image +section. Although XREGISTER is designed for use with same sized images, +it may be used with images of varying size. +In this case it is possible for the calculated overlap region to be vignetted, +as XREGISTER currently preserves the size of the input image when it shifts it. +For example if an image is much smaller than the reference image +it is possible for the image to be shifted outside of its own borders. +If the smallest image is used as a reference this will not occur. If +vignetting is detected the vignetted image section is printed on the +screen. Vignetting may also occur for a list of same-sized images +if the reference image is not included in the input image list, and the +computed shifts are all positive or negative as may occur in a time +sequence. Choosing a reference image with a shift which is in the +middle of the observed range of shifts in x and y will remove this problem. + +In non-interactive mode the parameters are set at task startup +and the input images are processed sequentially. If the \fIverbose\fR +flag is set messages about the progress of the task are printed on the +screen as the task is running. + +In interactive mode the user can mark the regions to be used +to compute the cross-correlation function on the image display, +define the initial shifts from the reference image to the input image +on the image display, show/set the data and algorithm parameters, +compute, recompute, and plot the cross-correlation function, experiment +with the various peak fitting algorithms, and overlay row and column +plots of the input and reference images with and without the initial and / or +computed shifts factored in. + +.ih +CURSOR COMMANDS + +The following graphics cursor commands are currently available in +XREGISTER. + + +.nf + Interactive Keystroke Commands + +? Print help +: Colon commands +t Define the offset between the reference and the input image +c Draw a contour plot of the cross-correlation function +x Draw a column plot of the cross-correlation function +y Draw a line plot of the cross-correlation function +r Redraw the current plot +f Recompute the cross-correlation function +o Enter the image overlay plot submenu +w Update the task parameters +q Exit + + + Colon Commands + +:mark Mark regions on the display +:show Show the current values of the parameters + + Show/Set Parameters + +:reference [string] Show/set the current reference image name +:input [string] Show/set the current input image name +:regions [string] Show/set the regions list +:shifts {string] Show/set the shifts database file name +:coords [string] Show/set the current coordinates file name +:output [string] Show/set the current output image name +:records [string] Show/set the current database record name +:xlag [value] Show/set the initial lag in x +:ylag [value] Show/set the initial lag in y +:dxlag [value] Show/set the incremental lag in x +:dylag [value] Show/set the incremental lag in y +:cregion [value] Show/set the current region +:background [string] Show/set the background fitting function +:border [value] Show/set border region for background fitting +:loreject [value] Show/set low side k-sigma rejection +:hireject [value] Show/set high side k-sigma rejection +:apodize [value] Show/set percent of end points to apodize +:filter [string] Show/set the default spatial filter +:correlation [string] Show/set cross-correlation function +:xwindow [value] Show/set width of correlation window in x +:ywindow [value] Show/set width of correlation window in y +:function [string] Show/set correlation peak centering function +:xcbox [value] Show/set the centering box width in x +:ycbox [value] Show/set the centering box width in y +.fi + + +The following submenu of image cursor commands is also available. + +.nf + Image Overlay Plot Submenu + + +? Print help +c Overlay the marked column of the reference image + with the same column of the input image +l Overlay the marked line of the reference image + with the same line of the input image +x Overlay the marked column of the reference image + with the x and y lagged column of the input image +y Overlay the marked line of the reference image + with the x and y lagged line of the input image +v Overlay the marked column of the reference image + with the x and y shifted column of the input image +h Overlay the marked line of the reference image + with the x and y shifted line of the input image +q Quit + + + Image Overlay Sub-menu Colon Commands + +:c [m] [n] Overlay the middle [mth] column of the reference image + with the mth [nth] column of the input image +:l [m] [n] Overlay the middle [mth] line of the reference image + with the mth [nth] line of the input image +:x [m] Overlay the middle [mth] column of the reference image + with the x and y lagged column of the input image +:y [m] Overlay the middle [mth] line of the reference image + with the x and y lagged line of the input image +:v [m] Overlay the middle [mth] column of the reference image + with the x and y shifted column of the input image +:h [m] Overlay the middle [mth] line of the reference image + with the x and y shifted line of the input image +.fi + +.ih +ALGORITHMS + +The cross-correlation function is computed in the following manner. +The symbols I and R refer to the input and reference images respectively. + +.nf +correlation = discrete + + = SUMj SUMi { I[i+xlag,j+ylag] } / (Nx * Ny) + = SUMj SUMi { R[i,j] } / (Nx * Ny) + sumsqI = sqrt (SUMj SUMi { (I[i+xlag,j+ylag] - ) ** 2 }) + sumsqR = sqrt (SUMj SUMi { (R[i,j] - ) ** 2 }) + + X = SUMj SUMi { (I[i+xlag,j+ylag] - ) * (R[i,j] - ) } + ---------------------------------------------------- + sumsqI * sumsqR + + +correlation = fourier + + = SUMj SUMi { I[i,j] } / (Nx * Ny) + = SUMj SUMi { R[i,j] } / (Nx * Ny) + sumsqI = sqrt (SUMj SUMi { (I[i,j] - ) ** 2 }) + sumsqR = sqrt (SUMj SUMi { (R[i,j] - ) ** 2 }) + FFTI = FFT { (I - ) / sumsqI } + FFTR = FFT { (R - ) / sumsqR } + + X = FFTINV { FFTR * conj { FFTI } } + + +correlation = difference + + = SUMj SUMi { I[i+xlag,j+ylag] } / (Nx * Ny) + = SUMj SUMi { R[i,j] } / (Nx * Ny) + + X = SUMj SUMi { abs ((I[i+xlag,j+ylag] - ) - (R[i,j] - )) } + X = 1.0 - X / max { X } +.fi + +.ih +EXAMPLES + +1. Register a list of images whose dimensions are all 256 by 256 pixels +and whose shifts with respect to the reference image are all less than +5.0 pixels, using the discrete cross-correlation algorithm and a search +window of 21 pixels in x and y. + +.nf + cl> xregister @inimlist refimage [*,*] shifts.db out=@outimlist \ + xwindow=21 ywindow=21 +.fi + +2. Register the previous list of images, but compute the cross_correlation +function using boxcar smoothed versions of the input images. + +.nf + cl> xregister @binimlist brefimage [*,*] shifts.db xwindow=21 \ + ywindow=21 + + cl> xregister @inimlist refimage [*,*] shifts.db out=@outimlist \ + records=@binimlist correlation=file +.fi + +3. Register the previous list of images but write the results to a simple +text file instead of a text database file and do the actual shifting with +the imshift task. + +.nf + cl> xregister @binimlist brefimage [*,*] shifts.db xwindow=21 \ + ywindow=21 databasefmt- + + cl> fields shifts.db 2,3 > shifts + + cl> imshift @inimlist @outimlist shifts_file=shifts +.fi + +4. Register list of 512 by 512 pixel square solar sunspot images that were +observed as a time series. Compute the cross-correlation function using +Fourier techniques, a search window of 21 pixels in x and y, an initial +shift of 10 pixels in x and 1 pixel in y, and use the computed shift of +the previous image as the initial guess for the current image. + +.nf + cl> xregister @inimlist refimage [*,*] shifts.db out=@outimlist \ + xlag=10 ylag=1 dxlag=INDEF dylag=INDEF correlation=fourier \ + xwindow=21 ywindow=21 +.fi + +5. Register two 2K square images interactively using discrete cross-correlation +and an initial search window of 15 pixels in x and y. + +.nf + cl> display refimage + + cl> xregister inimage refimage [900:1100,900:1100] shifts.db \ + xwindow=15 ywindow=15 interactive+ + + ... a contour plot of the cross-correlation function appears + with the graphics cursor ready to accept commands + + ... type x and y to get line and column plots of the cross- + correlation function at various points and c to return + to the default contour plot + + ... type ? to get a list of the available commands + + ... type :mark to mark a new region on the image display + + ... type f to recompute the cross-correlation function using + the new data + + ... increase the search window to 21 pixels in x and y + with the :xwindow 21 and :ywindow 21 commands + + ... type f to recompute the cross-correlation function with the + new search window + + ... type o to enter the image data overlay plot submenu, + move the cursor to a line in the displayed reference image + and type l to see of plot of the line in the input and + reference image, type h to see a plot of the same line in + the reference image and the x and y shifted line in the input + image, type q to return to the main menu + + ... type q to quit the task, and q again to verify the previous + q command +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +rv.fxcor,proto.imalign,images.imcombine,ctio.immatch,center1d,images.imshift +.endhelp diff --git a/pkg/images/immatch/doc/xyxymatch.hlp b/pkg/images/immatch/doc/xyxymatch.hlp new file mode 100644 index 00000000..82a8c8bb --- /dev/null +++ b/pkg/images/immatch/doc/xyxymatch.hlp @@ -0,0 +1,468 @@ +.help xyxymatch Jul95 images.immatch +.ih +NAME +xyxymatch -- Match pixel coordinate lists using various methods +.ih +USAGE +xyxymatch input reference output tolerance +.ih +PARAMETERS +.ls input +The list of input coordinate files. The input file is a whitespace-delimited +text table containing the coordinates. The \fIxcolumn\fR and \fIycolumn\fR +parameters define the coordinate columns to be used. +.le +.ls reference +The list of reference coordinate files. The number of reference coordinate +files must be one or equal to the number of input coordinate files. +The reference file is a whitespace-delimited +text table containing the coordinates. The \fIxrcolumn\fR and \fIyrcolumn\fR +parameters define the coordinate columns to be used. +.le +.ls output +The output matched x-y lists containing three pairs of numbers: the coordinates +of the object in the reference list in columns 1 and 2, the +coordinates of the object in the input list in columns 3 and 4, and +the line number of the objects in the original reference and input +lists in columns 5 and 6. +.le +.ls tolerance +The matching tolerance in pixels. +.le +.ls refpoints = "" +The list of tie points used to compute the linear transformation +from the input coordinate system to the reference coordinate system. Refpoints +is a text file containing the x-y coordinates of 1-3 reference list tie points +in the first line, followed by the x-y coordinates of the 1-3 corresponding +input tie points in succeeding +lines. If refpoints is undefined then the parameters \fIxin\fR, \fIyin\fR, +\fIxmag\fR, \fIymag\fR, \fIxrotation\fR, \fIyrotataion\fR, \fIxref\fR, +and \fIyref\fR are used to compute the linear transformation from the +input coordinate system to the reference coordinate system. +.le +.ls xin = INDEF, yin = INDEF +The x and y origin of the input coordinate system. Xin and yin default to +0.0 and 0.0 respectively. +.le +.ls xmag = INDEF, ymag = INDEF +The x and y scale factors in reference pixels per input pixels. Xmag and +ymag default to 1.0 and 1.0 respectively. +.le +.ls xrotation = INDEF, yrotation = INDEF +The x and y rotation angles measured in degrees counter-clockwise with +respect to the x axis. Xrotation and yrotation default to 0.0 and 0.0 +respectively. +.le +.ls xref = INDEF, yref = INDEF +The x and y origin of the reference coordinate system. Xref and yref default +to 0.0 and 0.0 respectively. +.le +.ls xcolumn = 1, ycolumn = 2 +The columns in the input coordinate list containing the x and y coordinate +values respectively. +.le +.ls xrcolumn = 1, yrcolumn = 2 +The columns in the reference coordinate list containing the x and y coordinate +values respectively. +.le +.ls separation = 9.0 +The minimum separation for objects in the input and reference coordinate +lists. Objects closer together than separation pixels +are removed from the input and reference coordinate lists prior to matching. +.le +.ls matching = "triangles" +The matching algorithm. The choices are: +.ls tolerance +A linear transformation is applied to the input coordinate list, +the transformed input list and the reference list are sorted, +points which are too close together are removed, and the input coordinates +which most closely match the reference coordinates within the +user specified tolerance are determined. The tolerance algorithm requires +an initial estimate for the linear transformation. This estimate can be +derived interactively by pointing to common objects in the two displayed +images, by supplying the coordinates of tie points via the +\fIrefpoints\fR file, or by setting the linear transformation parameters +\fIxin\fR, \fIyin\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, +\fIyrotation\fR, \fIxref\fR, and \fIyref\fR. Assuming that +well chosen tie points are supplied, the tolerance algorithm +functions well in the presence of any shifts, axis flips, x and y +scale changes, rotations, and axis skew, between the two coordinate +systems. The algorithm is sensitive to higher order distortion terms +in the coordinate transformation. +.le +.ls triangles +A linear transformation is applied to the input coordinate list, +the transformed input list and the reference list are sorted, points +which are too close together are removed, and the input coordinates +are matched to the reference coordinates using a triangle pattern +matching technique and the user specified tolerance parameter. +The triangles pattern matching algorithm does not require prior knowledge +of the linear transformation, although it will use one if one is supplied. +The algorithm functions well in the presence of +any shifts, axis flips, magnification, and rotation between the two coordinate +systems as long as both lists have a reasonable number of objects +in common and the errors in the computed coordinates are small. +However since the algorithm depends on comparisons of similar triangles, it +is sensitive to differences in the x and y coordinate scales, +any skew between the x and y axes, and higher order distortion terms +in the coordinate transformation. +.le +.le +.ls nmatch = 30 +The maximum number of reference and input coordinates used +by the "triangles" pattern matching algorithm. If either list contains +more coordinates than nmatch the lists are subsampled. Nmatch should be +kept small as the computation and memory requirements of the "triangles" +algorithm depend on a high power of the lengths of the respective lists. +.le +.ls ratio = 10.0 +The maximum ratio of the longest to shortest side of the +triangles generated by the "triangles" pattern matching algorithm. +Triangles with computed longest to shortest side ratios > ratio +are rejected from the pattern matching algorithm. \fIratio\fR should never +be set higher than 10.0 but may be set as low as 5.0. +.le +.ls nreject = 10 +The maximum number of rejection iterations for the "triangles" pattern +matching algorithm. +.le +.ls xformat = "%13.3f", yformat = "%13.3f" +The format of the output reference and input x and y coordinates. +By default the coordinates are output right justified in a field of +13 characters with 3 places following the decimal point. +.le +.ls interactive = no +Compute the initial linear transformation required to transform the +input coordinate coordinates to the reference coordinate system, by defining +up to three tie points using the image display and the image cursor. +.le +.ls verbose = yes +Print messages about the progress of the task ? +.le +.ls icommands = "" +The image display cursor. +.le + +.ih +DESCRIPTION + +XYXYMATCH matches the x and y coordinates in the reference coordinate list +\fIreference\fR to the corresponding x and y coordinates in the input +coordinate list \fIinput\fR to within a user specified tolerance +\fItolerance\fR, and writes the matched coordinates to the output +file \fIoutput\fR. The output file is suitable for input to the +GEOMAP task which computes the actual transformation required to +register the corresponding reference and input images. + +XYXYMATCH matches the coordinate lists by: 1) computing an initial +guess at the linear transformation required to match the input +coordinate system to the reference coordinate system, 2) applying +the computed transformation to the input coordinates, 3) sorting +the reference and input coordinates and removing points with a +minimum separation specified by the parameter \fIseparation\fR +from both lists, 4) matching the two lists using either the "tolerance" +or "triangles" algorithm, and 5) writing the matched list to the +output file. + +The initial estimate of the linear transformation is computed in one of +three ways. If \fIinteractive\fR is "yes" the user displays the reference and +input images corresponding to the reference and input coordinate files +on the image display, and marks up to three objects which the two +images have in common with the image cursor. The coordinates of these +tie points are used as tie points to compute the linear transformation. +If \fIrefpoints\fR is defined, the x-y coordinates of up to three tie +points are read from succeeding lines in the refpoints file. The format +of two sample refpoints files is shown below. + +.nf +# First sample refpoints file (1 reference file and N input files) + +x1 y1 [x2 y2 [x3 y3]] # tie points for reference coordinate file +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file 1 +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file 2 +... +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file N + + +# Second sample refpoints file (N reference files and N input files) + +x1 y1 [x2 y2 [x3 y3]] # tie points for reference coordinate file 1 +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file 1 +x1 y1 [x2 y2 [x3 y3]] # tie points for reference coordinate file 2 +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file 2 +... +x1 y1 [x2 y2 [x3 y3]] # tie points for reference coordinate file N +x1 y1 [x2 y2 [x3 y3]] # tie points for input coordinate file N + +.fi + +The coordinates of the tie points can be typed in by hand if \fIrefpoints\fR +is "STDIN". If the refpoints file is undefined the parameters +\fIxin\fR, \fIxin\fR, \fIxmag\fR, \fIymag\fR, \fIxrotation\fR, \fIyrotation\fR, +\fIxref\fR, and \fIyref\fR are used to compute the linear transformation +from the input coordinates [xi,yi] to the reference coordinates [xr,yr] +as shown below. Orientation and skew are the orientation of the x and y axes +and their deviation from non-perpendicularity respectively. + +.nf + xr = a + b * xi + c * yi + yr = d + e * xi + f * yi + + xrotation = orientation - skew / 2 + yrotation = orientation + skew / 2 + b = xmag * cos (xrotation) + c = -ymag * sin (yrotation) + e = xmag * sin (xrotation) + f = ymag * cos (yrotation) + a = xref - b * xin - c * yin = xshift + d = yref - e * xin - f * yin = yshift +.fi + +The reference and input coordinates are read from columns \fIxrcolumn\fR, +\fIyrcolumn\fR in the reference, and \fIxcolumn\fR, and \fIycolumn\fR in the +input coordinate lists respectively. The input coordinates are transformed +using the computed linear transformation and stars closer together than +\fIseparation\fR pixels are removed from both lists. + +The coordinate lists are matched using the algorithm specified by +the \fImatching\fR +parameter. If matching is "tolerance", XYXYMATCH searches the sorted +transformed input coordinate list for the object closest to the current +reference object within the matching tolerance \fItolerance\fR. +The major advantage of the "tolerance" algorithm is that it can deal +with x and y scale differences and axis skew in the coordinate +transformation. The major disadvantage is that the user must supply +tie point information in all but the simplest case of small x and y +shifts between the input and reference coordinate systems. + +If matching is "triangles" XYXYMATCH constructs a list of triangles +using up to \fInmatch\fR reference coordinates and transformed input +coordinates, and performs a pattern matching operation on the resulting +triangle lists. If the number of coordinates +in both lists is less than \fInmatch\fR the entire list is matched using +the "triangles" algorithm directly, otherwise the "triangles" algorithm +is used to estimate a new linear transformation, the input coordinate +list is transformed using the new transformation, and the entire list +is matched using the "tolerance" algorithm. The major advantage of the +"triangles" algorithm is that it requires no tie point information +from the user. The major disadvantages are that it is sensitive to +x and y scale differences and axis skews between the input and reference +coordinate systems and can be computationally expensive. + +The matched x and y reference and input coordinate lists are written to +columns 1 and 2, and 3 and 4 of the output file respectively, in a format +specified by the \fIxformat\fR and \fIyformat\fR parameters. +The respective line numbers in the original reference and input +coordinate files are written to columns 5 and 6 respectively. + +If \fIverbose\fR is yes, detailed messages about actions taken by the +task are written to the terminal as the task executes. + +.ih +ALGORITHMS + +The "triangles" algorithm uses a sophisticated pattern matching +technique which requires no tie point information from the user. +It is expensive computationally and hence is restricted to a maximum +of \fInmatch\fR objects from the reference and input coordinate lists. + +The "triangles" algorithm first generates a list +of all the possible triangles that can be formed from the points in each list. +For a list of nmatch points this number is the combinatorial factor +nmatch! / [(nmatch-3)! * 3!] or nmatch * (nmatch-1) * (nmatch-2) / 6. +The length of the perimeter, ratio of longest to shortest side, cosine +of the angle between the longest and shortest side, the tolerances in +the latter two quantities and the direction of the arrangement of the vertices +of each triangle are computed and stored in a table. +Triangles with vertices closer together than \fItolerance\fR or +with a ratio of the longest to shortest side greater than \fIratio\fR +are discarded. The remaining triangles are sorted in order of increasing +ratio. A sort merge algorithm is used to match the triangles using the +ratio and cosine information, the tolerances in these quantities, and +the maximum tolerances for both lists. Next the ratios of the +perimeters of the matched triangles are compared to the average ratio +for the entire list, and triangles which deviate too widely from the mean +are discarded. The number of triangles remaining are divided into +the number which match in the clockwise sense and the number which match +in the counter-clockwise sense. Those in the minority category +are eliminated. +The rejection step can be repeated up to \fInreject\fR times or until +no more rejections occur whichever comes first. +The last step in the algorithm is a voting procedure in which each remaining +matched triangle casts three votes, one for each matched pair of vertices. +Points which have fewer than half the maximum number of +votes are discarded. The final set of matches are written to the output file. + +The "triangles" algorithm functions well when the reference and +input coordinate lists have a sufficient number of objects (~50%, +in some cases as low as 25%) of their objects in common, any distortions +including x and y scale differences and skew between the two systems are small, +and the random errors in the coordinates are small. Increasing the value of the +\fItolerance\fR parameter will increase the ability to deal with distortions but +will also produce more false matches. + +.ih +FORMATS + +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi + +.ih +REFERENCES + +A detailed description of the "triangles" pattern matching algorithm used here +can be found in the article "A Pattern-Matching Algorithm for Two- +Dimensional Coordinate Lists" by E.J. Groth, A.J. 91, 1244 (1986). + +.ih +EXAMPLES + +1. Match the coordinate list of an image to the coordinate list of a reference +image using the triangles matching algorithm and a tolerance of 3 pixels. +Use the resulting matched list to compute the transformation +required to register the input image lpix to the reference image. +For completeness this example demonstrates how the individual input +and reference coordinate lists can be generated. + +.nf + cl> imlintran dev$pix[-*,*] lpix xrot=15 yrot=15 xmag=1.2 \ + ymag=1.2 xin=INDEF yin=INDEF xref=265.0 yref=265.0 \ + ncols=INDEF nlines=INDEF + + cl> daofind dev$pix fwhm=2.5 sigma=5.0 threshold=100.0 + cl> daofind lpix fwhm=2.5 sigma=5.0 threshold=100.0 + + cl> xyxymatch lpix.coo.1 pix.coo.1 xymatch toler=3 \ + matching=triangles + + cl> geomap xymatch geodb 1.0 512.0 1.0 512.0 +.fi + +2. Match the coordinate lists above using the tolerance matching algorithm +and the image display and cursor. + +.nf + cl> display dev$pix 1 fi+ + cl> display lpix 2 fi+ + + cl> xyxymatch lpix.coo.1 pix.coo.1 xymatch toler=3 \ + matching=tolerance interactive+ + + ... Mark three points in the reference image dev$pix + ... Mark three points in the input image lpix + + cl> geomap xymatch geodb 1.0 512.0 1.0 512.0 +.fi + +3. Repeat example 2 but run xyxymatch non-interactively by setting the +appropriate linear transformation parameters rather than marking stars +on the image display. + +.nf + cl> ... + + cl> xyxymatch lpix.coo.1 pix.coo.1 xymatch toler=3 \ + matching=tolerance xmag=1.2 ymag=1.2 xrot=165 \ + yrot=345 xref=646.10 yref=33.38 + + cl> geomap xymatch geodb 1.0 512.0 1.0 512.0 +.fi + +4. Repeat example 2 but run xyxymatch non-interactively +inputting the appropriate linear transformation via a list of tie points +rather than marking stars on the image display or creating a refpoints +file. + +.nf + cl> ... + + cl> type refpts + 442.0 409.0 380.0 66.0 69.0 460.0 + 82.0 347.0 207.0 84.0 371.0 469.0 + + cl> xyxymatch lpix.coo.1 pix.coo.1 xymatch toler=3 \ + refpoints=refpts matching=tolerance + + cl> geomap xymatch geodb 1.0 512.0 1.0 512.0 +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +daophot.daofind,lintran,imlintran,geomap,register,geotran +.endhelp diff --git a/pkg/images/immatch/geomap.par b/pkg/images/immatch/geomap.par new file mode 100644 index 00000000..27f46bc3 --- /dev/null +++ b/pkg/images/immatch/geomap.par @@ -0,0 +1,32 @@ +# GEOMAP Parameters + +# Required parameters +input,f,a,,,,The input coordinate files +database,f,a,,,,The output database file +xmin,r,a,INDEF,,,Minimum x reference coordinate value +xmax,r,a,INDEF,,,Maximum x reference coordinate value +ymin,r,a,INDEF,,,Minimum y reference coordinate value +ymax,r,a,INDEF,,,Maximum y reference coordinate value +transforms,s,h,"",,,The output transform records names +results,f,h,"",,,The optional results summary files +fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general|,,Fitting geometry + +# Surface fitting parameters +function,s,h,"polynomial",|chebyshev|legendre|polynomial|,,Surface type +xxorder,i,h,2,2,,Order of x fit in x +xyorder,i,h,2,2,,Order of x fit in y +xxterms,s,h,"half","|none|half|full|",,X fit cross terms type +yxorder,i,h,2,2,,Order of y fit in x +yyorder,i,h,2,2,,Order of y fit in y +yxterms,s,h,"half","|none|half|full|",,Y fit cross terms type +maxiter,i,h,0,,,Maximum number of rejection iterations +reject,r,h,3.0,,,Rejection limit in sigma units +calctype,s,h,"real",|real|double|,,'Computation type' + +# Output and graphics parameters +verbose,b,h,yes,,,Print messages about progress of task ? +interactive,b,h,yes,,,Fit transformation interactively ? +graphics,s,h,"stdgraph",,,Default graphics device +cursor,*gcur,h,,,,Graphics cursor + +mode,s,h,'ql' diff --git a/pkg/images/immatch/geotran.par b/pkg/images/immatch/geotran.par new file mode 100644 index 00000000..dcae9d1c --- /dev/null +++ b/pkg/images/immatch/geotran.par @@ -0,0 +1,45 @@ +# GEOTRAN Parameters + +# required parameters +input,f,a,,,,Input data +output,f,a,,,,Output data +database,f,a,,,,Name of GEOMAP database file +transforms,s,a,,,,Names of coordinate transforms in database file + +# change transformation parameters +geometry,s,h,"geometric",|linear|geometric|,,"Transformation type (linear,geometric)" +xin,r,h,INDEF,1.,,X origin of input frame in pixels +yin,r,h,INDEF,1.,,Y origin of input frame in pixels +xshift,r,h,INDEF,,,X origin shift in pixels +yshift,r,h,INDEF,,,Y origin shift in pixels +xout,r,h,INDEF,1.,,X origin of output frame in reference units +yout,r,h,INDEF,1.,,Y origin of output frame in reference units +xmag,r,h,INDEF,,,X scale of input picture in pixels per reference unit +ymag,r,h,INDEF,,,Y scale of input picture in pixels per reference unit +xrotation,r,h,INDEF,,,X axis rotation in degrees +yrotation,r,h,INDEF,,,Y axis rotation in degrees + +# output picture format parameters +xmin,r,h,INDEF,,,Minimum reference x value of output picture +xmax,r,h,INDEF,,,Maximum reference x value of output picture +ymin,r,h,INDEF,,,Minimum reference y value of output picture +ymax,r,h,INDEF,,,Maximum reference y value of output picture +xscale,r,h,1.0,0.0,,X scale of output picture in reference units per pixel +yscale,r,h,1.0,0.0,,Y scale of output picture in reference units per pixel +ncols,i,h,INDEF,1,,Number of columns in the output picture +nlines,i,h,INDEF,1,,Number of lines in the output picture + +# coordinate surface and image interpolation parameters +xsample,r,h,1.,1.,,Coordinate surface sampling interval in x +ysample,r,h,1.,1.,,Coordinate surface sampling interval in y +interpolant,s,h,"linear",,,"Interpolant" +boundary,s,h,"nearest",|nearest|constant|reflect|wrap|,,"Boundary extension (nearest,constant,reflect,wrap)" +constant,r,h,0.,,,Constant boundary extension +fluxconserve,b,h,yes,,,Preserve image flux? + +# working blocksize +nxblock,i,h,512,,,X dimension of working block size in pixels +nyblock,i,h,512,,,Y dimension of working block size in pixels +verbose,b,h,yes,,,Print messages about the progress of the task + +mode,s,h,'ql' diff --git a/pkg/images/immatch/geoxytran.par b/pkg/images/immatch/geoxytran.par new file mode 100644 index 00000000..c0b96ac0 --- /dev/null +++ b/pkg/images/immatch/geoxytran.par @@ -0,0 +1,28 @@ +# Parameter set for the GEOXYTRAN Task + +input,s,a,,,,Input coordinate files to be transformed +output,s,a,,,,Output transformed coordinate files +database,f,a,,,,The GEOMAP database file +transforms,s,a,,,,Names of the coordinate transforms in the database + +geometry,s,h,"geometric",|linear|geometric|,,'Transformation type (linear,geometric)' +direction,s,h,"forward","forward|backward",,Transformation direction (forward|backward) +xref,r,h,INDEF,,,X input origin in reference units +yref,r,h,INDEF,,,Y input origin in reference units +xmag,r,h,INDEF,,,X scale in output units per reference unit +ymag,r,h,INDEF,,,Y scale in output units per reference unit +xrotation,r,h,INDEF,,,X axis rotation in degrees +yrotation,r,h,INDEF,,,Y axis rotation in degrees +xout,r,h,INDEF,,,X output origin in output units +yout,r,h,INDEF,,,Y output origin in output units +xshift,r,h,INDEF,,,X origin shift in output units +yshift,r,h,INDEF,,,Y origin shift in output units + +xcolumn,i,h,1,1,100,Input column containing the x coordinate +ycolumn,i,h,2,1,100,Input column containing the y coordinate +calctype,s,h,"real",|real|double|,,Data type for evaluation coordinates +xformat,s,h,"",,,Output format of the x coordinate +yformat,s,h,"",,,Output format of the y coordinate +min_sigdigits,i,h,7,,,Minimum precision of output x and y coordinates + +mode,s,h,'ql' diff --git a/pkg/images/immatch/gregister.cl b/pkg/images/immatch/gregister.cl new file mode 100644 index 00000000..70c048e7 --- /dev/null +++ b/pkg/images/immatch/gregister.cl @@ -0,0 +1,51 @@ +# GREGISTER -- Register a list of images by calling the GEOTRAN task with the +# appropriate parameters. + +procedure gregister (input, output, database, transforms, geometry, xmin, xmax, + ymin, ymax, xscale, yscale, ncols, nlines, xsample, ysample, + interpolant, boundary, constant, fluxconserve, nxblock, nyblock, + verbose) + +string input +string output +string database +string transforms +string geometry +real xmin +real xmax +real ymin +real ymax +real xscale +real yscale +int ncols +int nlines +real xsample +real ysample +string interpolant +string boundary +real constant +bool fluxconserve +int nxblock +int nyblock +bool verbose + +begin + # Declare local variables + string din, dout, ddata, dtran + + # Get the parameters. + din = input + dout = output + ddata = database + dtran = transforms + + # Call GEOTRAN. + geotran (input=din, output=dout, database=ddata, transforms=dtran, + geometry=geometry, xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, + xscale=xscale, yscale=yscale, ncols=ncols, nlines=nlines, + interpolant=interpolant, boundary=boundary, constant=constant, + fluxconserve=fluxconserve, xsample=xsample, ysample=ysample, + nxblock=nxblock, nyblock=nyblock, xin=INDEF, yin=INDEF, xout=INDEF, + yout=INDEF, xshift=INDEF, yshift=INDEF, xmag=INDEF, ymag=INDEF, + xrotation=INDEF, yrotation=INDEF, verbose=verbose) +end diff --git a/pkg/images/immatch/gregister.par b/pkg/images/immatch/gregister.par new file mode 100644 index 00000000..ad2e28b3 --- /dev/null +++ b/pkg/images/immatch/gregister.par @@ -0,0 +1,33 @@ +# GREGISTER Parameters + +# required parameters +input,f,a,,,,Input data +output,f,a,,,,Output data +database,f,a,,,,Name of GEOMAP database file +transforms,s,a,,,,Names of coordinate transforms in database file +geometry,s,h,'geometric',,,'Geometry (linear,distortion,geometric)' + +# output picture format parameters +xmin,r,h,INDEF,,,Minimum reference x value of output picture +xmax,r,h,INDEF,,,Maximum reference x value of output picture +ymin,r,h,INDEF,,,Minimum reference y value of output picture +ymax,r,h,INDEF,,,Maximum reference y value of output picture +xscale,r,h,1.0,0.,,X scale of output picture in reference units per pixel +yscale,r,h,1.0,0.,,Y scale of output picture in reference units per pixel +ncols,i,h,INDEF,1,,Number of columns in the output picture +nlines,i,h,INDEF,1,,Number of lines in the output picture + +# coordinate surface and image interpolation parameters +xsample,r,h,1.0,1.0,,Coordinate surface sampling area in x +ysample,r,h,1.0,1.0,,Coordinate surface sampling area in y +interpolant,s,h,'linear',,,'Interpolant (nearest,linear,poly3,poly5,spline3)' +boundary,s,h,'nearest',|nearest|constant|reflect|wrap|,,'Boundary extension (nearest,constant,reflect,wrap)' +constant,r,h,0.,,,Constant for constant boundary extension +fluxconserve,b,h,yes,,,Preserve image flux ? + +# blocking factors +nxblock,i,h,512,,,X dimension of working block size in pixels +nyblock,i,h,512,,,Y dimension of working block size in pixels +verbose,b,h,yes,,,Print messages about the progress of the task ? + +mode,s,h,'ql' diff --git a/pkg/images/immatch/imalign.cl b/pkg/images/immatch/imalign.cl new file mode 100644 index 00000000..2e6a5f69 --- /dev/null +++ b/pkg/images/immatch/imalign.cl @@ -0,0 +1,119 @@ +# IMALIGN - Register a set of images using the results of the IMCENTROID, +# and the IMSHIFT, and IMCOPY tasks. + +procedure imalign (input, reference, coords, output) + +begin + bool shifts_found, trim_found + string tmpfile, outfile, shiftfile, trimsect, tmp, junk + string l_input, l_reference, l_coords, l_output + int x1, x2, y1, y2 + real xshift, yshift + struct line + + # Set up some temporary files. + tmpfile = mktemp ("tmp$ia_tmp.") + outfile = mktemp ("tmp$ia_tmp.") + shiftfile = mktemp ("tmp$ia_tmp.") + + # Get the required parameters. + l_input = input + l_reference = reference + l_coords = coords + l_output = output + + # Write the output names to outfile. + sections (l_output, option="fullname", > outfile) + + # Compute the centers and relative shifts. + imcentroid (l_input, l_reference, l_coords, shifts=shifts, + boxsize=boxsize, bigbox=bigbox, negative=negative, + background=background, lower=lower, upper=upper, + niterate=niterate, tolerance=tolerance, maxshift=maxshift, + verbose=verbose, >& tmpfile) + + # Print the centering results on the screen? + if (verbose) + type (tmpfile) + + # Shift the images. + if (shiftimages) { + + # Read the shifts. + shifts_found = no + list = tmpfile + while (fscan (list, line) != EOF) { + tmp = substr (line, 2, 7) + if (tmp == "Shifts") { + shifts_found = yes + break + } + } + + # Decode the shifts. + if (shifts_found) + while (fscan (list, junk, xshift, junk, yshift, junk) == 5) + print (xshift, " ", yshift, >> shiftfile) + else + error (1, "No shifts were calculated.") + + # Shift the images. + print ("\n# Shifting images:\n") + imshift (l_input, "@"//outfile, shifts_file=shiftfile, + interp_type=interp_type, boundary_type=boundary_type, + constant=constant) + + # Trim the images. + if (trimimages) { + + # Check for vignetting. + trim_found = no + while (fscanf (list, "%s = [%d:%d,%d:%d]", line, x1, x2, + y1, y2) != EOF) { + tmp = substr (line, 2, 5) + if (tmp == "Vign") { + print ("Images not trimmed ! Vignetting is present.") + trim_found = no + break + } else if (tmp == "Trim") { + trim_found = yes + break + } + } + + # Trim the images. + if (!trim_found) { + print ("Images not trimmed ! Trim section is undefined.") + } else { + + # Correct for boundary extension "contamination". + if (interp_type == "poly3") { + x1 += 1; x2 -= 1; y1 += 1; y2 -= 1 + } else if (interp_type == "poly5" || + interp_type == "spline3") { + x1 += 2; x2 -= 2; y1 += 2; y2 -= 2 + } + + if (1 <= x1 && x1 <= x2 && 1 <= y1 && y1 <= y2) { + trimsect = "["//x1//":"//x2//","//y1//":"//y2//"]" + + list = outfile; delete (tmpfile, ver-, >& "dev$null") + while (fscan (list, tmp) != EOF) + print (tmp//trimsect, >> tmpfile) + + print ("# Trimming images: corrected section = ", + trimsect) + imcopy ("@"//tmpfile, "@"//outfile, verbose-) + + } else { + print ("Images not trimmed ! No overlap region.") + } + } + } + } + + list = "" + delete (tmpfile, ver-, >& "dev$null") + delete (outfile, ver-, >& "dev$null") + delete (shiftfile, ver-, >& "dev$null") +end diff --git a/pkg/images/immatch/imalign.par b/pkg/images/immatch/imalign.par new file mode 100644 index 00000000..2434f735 --- /dev/null +++ b/pkg/images/immatch/imalign.par @@ -0,0 +1,28 @@ +input,s,a,,,,"Input images" +reference,s,a,,,,"Reference image" +coords,s,a,,,,"Reference coordinates file" +output,s,a,,,,"Output images" +shifts,s,h,"",,,"Initial shifts file" + +boxsize,i,h,7,1,,"Size of the small centering box" +bigbox,i,h,11,1,,"Size of the big centering box" +negative,b,h,no,,,"Are the features negative ?" +background,r,h,INDEF,,,"Reference background level" +lower,r,h,INDEF,,,"Lower threshold for data" +upper,r,h,INDEF,,,"Upper threshold for data" +niterate,i,h,3,2,,"Maximum number of iterations" +tolerance,i,h,0,0,,"Tolerance for convergence" +maxshift,r,h,INDEF,,,"Maximum acceptable pixel shift" + +shiftimages,b,h,yes,,,"Shift the images ?" +interp_type,s,h,"linear","|nearest|linear|poly3|poly5|spline3|",,"Interpolant" +boundary_type,s,h,"nearest","|constant|nearest|reflect|wrap|",,"Boundary type" +constant,r,h,0.,,,"Constant for constant boundary extension" + +trimimages,b,h,yes,,,"Trim the shifted images ?" + +verbose,b,h,yes,,,"Print the centers, shifts, and trim section ?" + +list,*s,h + +mode,s,h,'ql' diff --git a/pkg/images/immatch/imcentroid.par b/pkg/images/immatch/imcentroid.par new file mode 100644 index 00000000..8a93d787 --- /dev/null +++ b/pkg/images/immatch/imcentroid.par @@ -0,0 +1,16 @@ +input,s,a,,,,"List of input images" +reference,s,a,"",,,"Reference image" +coords,s,a,,,,"Reference coordinates file" +shifts,s,h,"",,,"Initial shifts file" + +boxsize,i,h,7,1,,"Size of the fine centering box" +bigbox,i,h,11,1,,"Size of the coarse centering box" + +negative,b,h,no,,,"Are the features negative ?" +background,r,h,INDEF,,,"Reference background level" +lower,r,h,INDEF,,,"Lower threshold for data" +upper,r,h,INDEF,,,"Upper threshold for data" +niterate,i,h,3,2,,"Maximum number of iterations" +tolerance,i,h,0,0,,"Tolerance for convergence" +maxshift,r,h,INDEF,,,"Maximum acceptable pixel shift" +verbose,b,h,yes,,,"Print the centroids for every source ?" diff --git a/pkg/images/immatch/imcombine.par b/pkg/images/immatch/imcombine.par new file mode 100644 index 00000000..ead908e4 --- /dev/null +++ b/pkg/images/immatch/imcombine.par @@ -0,0 +1,43 @@ +# IMCOMBINE -- Image combine parameters + +input,s,a,,,,List of images to combine +output,s,a,,,,List of output images +headers,s,h,"",,,List of header files (optional) +bpmasks,s,h,"",,,List of bad pixel masks (optional) +rejmasks,s,h,"",,,List of rejection masks (optional) +nrejmasks,s,h,"",,,List of number rejected masks (optional) +expmasks,s,h,"",,,List of exposure masks (optional) +sigmas,s,h,"",,,List of sigma images (optional) +imcmb,s,h,"$I",,,Keyword for IMCMB keywords +logfile,s,h,"STDOUT",,,"Log file +" +combine,s,h,"average","average|median|lmedian|sum|quadrature|nmodel",,Type of combine operation +reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection +project,b,h,no,,,Project highest dimension of input images? +outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype +outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) +offsets,f,h,"none",,,Input image offsets +masktype,s,h,"none","",,Mask type +maskvalue,s,h,"0",,,Mask value +blank,r,h,0.,,,"Value if there are no pixels +" +scale,s,h,"none",,,Image scaling +zero,s,h,"none",,,Image zero point offset +weight,s,h,"none",,,Image weights +statsec,s,h,"",,,Image section for computing statistics +expname,s,h,"",,,"Image header exposure time keyword +" +lthreshold,r,h,INDEF,,,Lower threshold +hthreshold,r,h,INDEF,,,Upper threshold +nlow,i,h,1,0,,minmax: Number of low pixels to reject +nhigh,i,h,1,0,,minmax: Number of high pixels to reject +nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) +mclip,b,h,yes,,,Use median in sigma clipping algorithms? +lsigma,r,h,3.,0.,,Lower sigma clipping factor +hsigma,r,h,3.,0.,,Upper sigma clipping factor +rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) +gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) +snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) +sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections +pclip,r,h,-0.5,,,pclip: Percentile clipping parameter +grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection diff --git a/pkg/images/immatch/immatch.cl b/pkg/images/immatch/immatch.cl new file mode 100644 index 00000000..eeecba73 --- /dev/null +++ b/pkg/images/immatch/immatch.cl @@ -0,0 +1,39 @@ +#{ IMMATCH -- The Image Matching Package. + +set immatch = "images$immatch/" +set imgeom = "images$imgeom/" +set imutil = "images$imutil/" + +package immatch + +# Tasks. + +task imcentroid, + imcombine, + geomap, + geotran, + geoxytran, + linmatch, + psfmatch, + skyxymatch, + wcscopy, + wcsxymatch, + xregister, + xyxymatch = "immatch$x_images.e" + +task imshift = "imgeom$x_images.e" +task imcopy = "imutil$x_images.e" +task sections = "imutil$x_images.e" +hidetask imshift, imcopy, sections + +# Scripts + +task gregister = "immatch$gregister.cl" +task imalign = "immatch$imalign.cl" +task skymap = "immatch$skymap.cl" +task sregister = "immatch$sregister.cl" +task wcsmap = "immatch$wcsmap.cl" +task wregister = "immatch$wregister.cl" + + +clbye() diff --git a/pkg/images/immatch/immatch.hd b/pkg/images/immatch/immatch.hd new file mode 100644 index 00000000..7478b683 --- /dev/null +++ b/pkg/images/immatch/immatch.hd @@ -0,0 +1,32 @@ +# Help directory for the IMMATCH package + +$immatch = "images$immatch/" +$doc = "images$immatch/doc/" +$geometry = "images$immatch/src/geometry/" +$imcombine = "images$immatch/src/imcombine/" +$linmatch = "images$immatch/src/linmatch/" +$listmatch = "images$immatch/src/listmatch/" +$psfmatch = "images$immatch/src/psfmatch/" +$wcsmatch = "images$immatch/src/wcsmatch/" +$xregister = "images$immatch/src/xregister/" + +geomap hlp=doc$geomap.hlp, src=geometry$t_geomap.x +geotran hlp=doc$geotran.hlp, src=geometry$t_geotran.x +geoxytran hlp=doc$geoxytran.hlp, src=geometry$t_geoxytran.x +gregister hlp=doc$gregister.hlp, src=immatch$gregister.cl +imalign hlp=doc$imalign.hlp, src=immatch$imalign.cl +imcentroid hlp=doc$imcentroid.hlp, src=listmatch$t_imctroid.x +imcombine hlp=doc$imcombine.hlp, src=imcombine$t_imcombine.x +linmatch hlp=doc$linmatch.hlp, src=linmatch$t_linmatch.x +psfmatch hlp=doc$psfmatch.hlp, src=psfmatch$t_psfmatch.x +skymap hlp=doc$skymap.hlp, src=immatch$skymap.cl +skyxymatch hlp=doc$skyxymatch.hlp, src=wcsmatch$t_skyxymatch.x +sregister hlp=doc$sregister.hlp, src=immatch$sregister.cl +wcscopy hlp=doc$wcscopy.hlp, src=wcsmatch$t_wcscopy.x +wcsmap hlp=doc$wcsmap.hlp, src=immatch$wcsmap.cl +wcsxymatch hlp=doc$wcsxymatch.hlp, src=wcsmatch$t_wcsxymatch.x +wregister hlp=doc$wregister.hlp, src=immatch$wregister.cl +xregister hlp=doc$xregister.hlp, src=xregister$t_xregister.x +xyxymatch hlp=doc$xyxymatch.hlp, src=listmatch$t_xyxymatch.x +revisions sys=Revisions + diff --git a/pkg/images/immatch/immatch.men b/pkg/images/immatch/immatch.men new file mode 100644 index 00000000..f9829bd7 --- /dev/null +++ b/pkg/images/immatch/immatch.men @@ -0,0 +1,18 @@ + geomap - Compute geometric transforms using matched coordinate lists + geotran - Transform 1-D or 2-D images using various mapping transforms + geoxytran - Transform coordinate lists using the geomap transforms + gregister - Register 1-D or 2-D images using the geomap transforms + imalign - Align and register 2-D images using a reference pixel list + imcentroid - Compute and print relative shifts for a list of 2-D images + imcombine - Combine images pixel-by-pixel using various algorithms + linmatch - Match the linear intensity scales of 1-D or 2-D images + psfmatch - Match the point-spread functions of 1-D or 2-D images + skymap - Compute geometric transforms using the image celestial wcs + skyxymatch - Generate matched pixel lists using the image celestial wcs + sregister - Register 1-D or 2-D images using the image celestial wcs + wcscopy - Copy the wcs from one image to another + wcsmap - Compute geometric transforms using the image wcs + wcsxymatch - Generate matched pixel lists using the image wcs + wregister - Register 1-D or 2-D images using the image wcs + xregister - Register 1-D or 2-D images using x-correlation techniques + xyxymatch - Match pixel coordinate lists diff --git a/pkg/images/immatch/immatch.par b/pkg/images/immatch/immatch.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/immatch/immatch.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/immatch/linmatch.par b/pkg/images/immatch/linmatch.par new file mode 100644 index 00000000..ae3183d5 --- /dev/null +++ b/pkg/images/immatch/linmatch.par @@ -0,0 +1,30 @@ +input,s,a,,,,"Input images" +reference,s,a,,,,"Reference images or reference photometry files" +regions,s,a,"",,,"Reference image regions or input image photometry files" +lintransform,f,a,"",,,"Input/output linear transformation database file" +output,s,h,"",,,"Output scaled images" +databasefmt,b,h,yes,,,"Write the linear transformatoin file in database format ?" +append,b,h,yes,,,"Open transformation database for writing in append mode" +records,s,h,"",,,"List of scale factors database records" +shifts,f,h,"",,,"Input shifts file" +xshift,r,h,0.,,,"The input to reference image x shift" +yshift,r,h,0.,,,"The input to reference image y shift" +dnx,r,h,31.,,,"X width of data region to extract" +dny,r,h,31.,,,"Y width of data region to extract" +maxnregions,i,h,100,,,"Maximum number of regions or objects" +scaling,s,h,"mean mean",,,"Scaling algorithm (number,mean,median,mode,fit,photometry)" +datamin,r,h,INDEF,,,"The minimum good data value" +datamax,r,h,INDEF,,,"The maximum good data value" +maxiter,i,h,10,,,"Maximum number of least squares fitting iterations" +nreject,i,h,0,,,"Maximum number of rejection iterations" +loreject,r,h,INDEF,,,"Low-side fitting sigma rejection criterion" +hireject,r,h,INDEF,,,"High-side fitting sigma rejection criterion" +gain,s,h,"1.0 1.0",,,"Image header gain keyword or value" +readnoise,s,h,"0.0 0.0",,,"Image header readout noise keyword or value" +interactive,b,h,no,,,"Interactive mode ?" +verbose,b,h,yes,,,"Verbose mode ?" +graphics,s,h,"stdgraph",,,"The standard graphics device" +display,s,h,"stdimage",,,"The standard image display device" +gcommands,*gcur,h,"",,,"The graphics cursor" +icommands,*imcur,h,"",,,"The image display cursor" +mode,s,h,"ql",,, diff --git a/pkg/images/immatch/mkpkg b/pkg/images/immatch/mkpkg new file mode 100644 index 00000000..988c7963 --- /dev/null +++ b/pkg/images/immatch/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMMATCH Package + +libpkg.a: + @src + ; diff --git a/pkg/images/immatch/psfmatch.par b/pkg/images/immatch/psfmatch.par new file mode 100644 index 00000000..042b383b --- /dev/null +++ b/pkg/images/immatch/psfmatch.par @@ -0,0 +1,40 @@ +# The PSFMATCH parameters + +input,f,a,,,,Input images +reference,f,a,,,,Reference images or reference psfs +psfdata,f,a,,,,Objects lists or input psfs +kernel,f,a,"",,,Input/output convolution kernels +output,f,h,"",,,Output convolved images + +convolution,s,h,"image","|image|psf|kernel|",,Kernel computation method +dnx,i,h,31,,,X width of data region to extract +dny,i,h,31,,,Y width of data region to extract +pnx,i,h,15,,,X width of convolution kernel +pny,i,h,15,,,Y width of convolution kernel + +center,b,h,"yes",,,Center the psf objects ? +background,s,h,"median",,,Background fitting function +loreject,r,h,INDEF,,,Low sigma rejection threshold +hireject,r,h,INDEF,,,High sigma rejection threshold +apodize,r,h,0,,,Fraction of endpoints to apodize + +fluxratio,s,h,INDEF,,,The reference to input integrated flux ratio +filter,s,h,"replace","|none|cosbell|replace|model|",,Filter/replace option +sx1,r,h,INDEF,,,Inner x spectral frequency for cosine bell filter +sx2,r,h,INDEF,,,Outer x spectral frequency for cosine bell filter +sy1,r,h,INDEF,,,Inner y spectral frequency for cosine bell filter +sy2,r,h,INDEF,,,Outer y spectral frequency for cosine bell filter +radsym,b,h,no,,,Radial symmetry for cosine bell filter ? +threshold,r,h,0.2,0.0,1.0,Threshold in fourier spectrum for modeling/replacing +normfactor,r,h,1.0,,,The kernel normalization factor + +boundary,s,h,'nearest',"|constant|nearest|reflect|wrap|",,Boundary extension +constant,r,h,0.0,,,Constant for constant boundary extension + +interactive,b,h,no,,,Interactive mode ? +verbose,b,h,yes,,,Verbose mode ? +graphics,s,h,"stdgraph",,,The default graphics device +display,s,h,"stdimage",,,The default display device +gcommands,*gcur,h,"",,,Graphics cursor +icommands,*imcur,h,"",,,Image display cursor +mode,s,h,"ql" diff --git a/pkg/images/immatch/skymap.cl b/pkg/images/immatch/skymap.cl new file mode 100644 index 00000000..f8785eb0 --- /dev/null +++ b/pkg/images/immatch/skymap.cl @@ -0,0 +1,114 @@ +# SKYMAP -- Compute the geometric transformation required to register an +# input image to a reference image using celestial coordinate WCS information +# in the input and reference image headers. SKYMAP is a simple script task +# which calls the SKYXYMATCH task to compute the control points followed by +# the GEOMAP task to compute the transformation. + + +procedure skymap (input, reference, database) + +file input {prompt="The input images"} +file reference {prompt="The input reference images"} +file database {prompt="The output database file"} +file transforms {"", prompt="The database transform names"} +file results {"", prompt="The optional results summary files"} +real xmin {INDEF, + prompt="Minimum logical x reference coordinate value"} +real xmax {INDEF, + prompt="Maximum logical x reference coordinate value"} +real ymin {INDEF, + prompt="Minimum logical y reference coordinate value"} +real ymax {INDEF, + prompt="Maximum logical y reference coordinate value"} +int nx {10, prompt="Number of grid points in x"} +int ny {10, prompt="Number of grid points in y"} +string wcs {"world", prompt="The default world coordinate system", + enum="physical|world"} +string xformat {"%10.3f", prompt="Output logical x coordinate format"} +string yformat {"%10.3f", prompt="Output logical y coordinate format"} +string rwxformat {"", + prompt="Output reference world x coordinate format"} +string rwyformat {"", + prompt="Output reference world y coordinate format"} +string wxformat {"", prompt="Output world x coordinate format"} +string wyformat {"", prompt="Output world y coordinate format"} +string fitgeometry {"general", + prompt="Fitting geometry", + enum="shift|xyscale|rotate|rscale|rxyscale|general"} +string function {"polynomial", prompt="Surface type", + enum="legendre|chebyshev|polynomial"} +int xxorder {2, prompt="Order of x fit in x"} +int xyorder {2, prompt="Order of x fit in y"} +string xxterms {"half", enum="none|half|full", + prompt="X fit cross terms type"} +int yxorder {2, prompt="Order of y fit in x"} +int yyorder {2, prompt="Order of y fit in y"} +string yxterms {"half", enum="none|half|full", + prompt="Y fit cross terms type"} +real reject {INDEF, prompt="Rejection limit in sigma units"} +string calctype {"real", prompt="Computation precision", + enum="real|double"} +bool verbose {yes, prompt="Print messages about progress of task ?"} +bool interactive {yes, prompt="Compute transformation interactively ? "} +string graphics {"stdgraph", prompt="Default graphics device"} +gcur gcommands {"", prompt="Graphics cursor"} + + +begin + # Declare local variables. + int nimages + string tinput, treference, tcoords, toutput, ttransforms, tresults + string tsections1, tsections2, tcname + + # Cache the sections task. + cache sections + + # Get the query parameters. + tinput = input + treference = reference + toutput = database + if (transforms == "") { + ttransforms = tinput + } else { + ttransforms = transforms + } + tresults = results + + # Get the temproary coordinates file list. + tsections1 = mktemp ("tmps1") + tsections2 = mktemp ("tmps2") + if (access ("imxymatch.1")) { + tcoords = mktemp ("imxymatch") + } else { + tcoords = "imxymatch" + } + sections (tinput, option="fullname", > tsections1) + nimages = sections.nimages + for (i = 1; i <= nimages; i = i + 1) { + printf ("%s\n", tcoords // "." // i, >> tsections2) + } + delete (tsections1, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + tcname = "@"//tsections2 + + # Compute the control points. + skyxymatch (tinput, treference, tcname, coords="grid", xmin=xmin, + xmax=xmax, ymin=ymin, ymax=ymax, nx=nx, ny=ny, wcs=wcs, + xcolumn=1, ycolumn=1, xunits="", yunits="", xformat=xformat, + yformat=yformat, rwxformat=rwxformat, rwyformat=rwyformat, + wxformat=wxformat, wyformat=wyformat, min_sigdigits=7, verbose=no) + + # Compute the transformation. + geomap (tcname, toutput, xmin, xmax, ymin, ymax, transforms=ttransforms, + results=tresults, fitgeometry=fitgeometry, function=function, + xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, + yyorder=yyorder, yxterms=yxterms, reject=reject, calctype=calctype, + verbose=verbose, interactive=interactive, graphics=graphics, + cursor=gcommands) + + # Cleanup. + delete (tcname, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + delete (tsections2, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") +end diff --git a/pkg/images/immatch/skyxymatch.par b/pkg/images/immatch/skyxymatch.par new file mode 100644 index 00000000..7d1f42e1 --- /dev/null +++ b/pkg/images/immatch/skyxymatch.par @@ -0,0 +1,26 @@ +# Parameter file for the SKYXYMATCH task + +input,f,a,,,,Input images +reference,f,a,,,,Input reference images +output,f,a,,,,Output matched coordinate lists +coords,f,h,"grid",,,Reference coordinate lists +xmin,r,h,INDEF,,,Minimum logical x reference coordinate value +xmax,r,h,INDEF,,,Maximum logical x reference coordinate value +ymin,r,h,INDEF,,,Minimum logical y reference coordinate value +ymax,r,h,INDEF,,,Maximum logical y reference coordinate value +nx,i,h,10,1,,Number of grid points in x +ny,i,h,10,1,,Number of grid points in y +wcs,s,h,"world","|physical|world|",,Input coordinate system +xcolumn,i,h,1,1,,Input column containing x coordinate +ycolumn,i,h,2,1,,Input column containing y coordinate +xunits,s,h,"",,,Input x coordinate units +yunits,s,h,"",,,Input y coordinate units +xformat,s,h,"%10.3f",,,Output logical x coordinate format +yformat,s,h,"%10.3f",,,Output logical y coordinate format +rwxformat,s,h,"",,,Output reference world x coordinate format +rwyformat,s,h,"",,,Output reference world y coordinate format +wxformat,s,h,"",,,Output world x coordinate format +wyformat,s,h,"",,,Output world y coordinate format +min_sigdigits,i,h,7,,,Minimum number of significant digits +verbose,b,h,yes,,,Verbose mode ? +mode,s,h,ql,,, diff --git a/pkg/images/immatch/src/geometry/geofunc.gx b/pkg/images/immatch/src/geometry/geofunc.gx new file mode 100644 index 00000000..3b34a207 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geofunc.gx @@ -0,0 +1,250 @@ +include +include + +$for (rd) + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmag$t (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +PIXEL xmag, ymag #I/O the x and y magnification +PIXEL xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_$INDEF$T(xmag)) + xmag = PIXEL (dtgetr (dt, rec, "xmag")) + if (IS_$INDEF$T(ymag)) + ymag = PIXEL (dtgetr (dt, rec, "ymag")) + if (IS_$INDEF$T(xrot)) + xrot = DEGTORAD (PIXEL(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_$INDEF$T(yrot)) + yrot = DEGTORAD (PIXEL (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmag$t (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshift$t (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +PIXEL xout, yout #I the input coordinate system origin +PIXEL xref, yref #I the reference coordinate system origin +PIXEL xshift, yshift #I the origin shift in input coordinates + +$if (datatype == r) +PIXEL gsgetr(), gseval() +$else +PIXEL dgsgetd(), dgseval() +$endif + +begin +$if (datatype == r) + if (IS_$INDEF$T(xref)) + xref = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (IS_$INDEF$T(yref)) + yref = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMAX)) / 2.0 + + if (IS_$INDEF$T(xout)) + xout = gseval (sx1, xref, yref) + if (IS_$INDEF$T(yout)) + yout = gseval (sy1, xref, yref) + + if (IS_$INDEF$T(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - gseval (sy1, xref, yref) +$else + if (IS_$INDEF$T(xref)) + xref = (dgsgetd (sx1, GSXMIN) + dgsgetd (sx1, GSXMAX)) / 2.0d0 + if (IS_$INDEF$T(yref)) + yref = (dgsgetd (sy1, GSYMIN) + dgsgetd (sy1, GSYMAX)) / 2.0d0 + + if (IS_$INDEF$T(xout)) + xout = dgseval (sx1, xref, yref) + if (IS_$INDEF$T(yout)) + yout = dgseval (sy1, xref, yref) + + if (IS_$INDEF$T(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - dgseval (sy1, xref, yref) +$endif + + call geo_xyshift$t (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmag$t (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +PIXEL xscale, yscale #I the x and y scales +PIXEL xrotation,yrotation #I the x and y axis rotation angles in radians + +PIXEL cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +$if (datatype == r) +real gsgetr() +int gsgeti() +$else +double dgsgetd() +int dgsgeti() +$endif + +begin + # Get the current solution. + call smark (sp) +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call salloc (xcoeff, ncoeff, TY_PIXEL) + call salloc (ycoeff, ncoeff, TY_PIXEL) +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Mem$t[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Mem$t[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Mem$t[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Mem$t[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. +$if (datatype == r) + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = gsget$t (sx1, GSXMAX) - gsget$t (sx1, GSXMIN) +$else + if (dgsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = dgsget$t (sx1, GSXMAX) - dgsget$t (sx1, GSXMIN) +$endif + Mem$t[xcoeff+GS_SAVECOEFF+1] = Mem$t[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Mem$t[xcoeff+GS_SAVECOEFF+2] = Mem$t[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } +$if (datatype == r) + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = gsget$t (sy1, GSYMAX) - gsget$t (sy1, GSYMIN) +$else + if (dgsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = dgsget$t (sy1, GSYMAX) - dgsget$t (sy1, GSYMIN) +$endif + Mem$t[ycoeff+GS_SAVECOEFF+1] = Mem$t[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Mem$t[ycoeff+GS_SAVECOEFF+2] = Mem$t[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + +$if (datatype == r) + # Free the original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore the edited fit. + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + # Free the original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore the edited fit. + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshift$t (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +PIXEL xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif + +begin + call smark (sp) + + # Allocate working space. +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call salloc (xcoeff, ncoeff, TY_PIXEL) + call salloc (ycoeff, ncoeff, TY_PIXEL) + + # Get coefficients. +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + + # Shift the coefficients. + Mem$t[xcoeff+GS_SAVECOEFF] = Mem$t[xcoeff+GS_SAVECOEFF] + xshift + Mem$t[ycoeff+GS_SAVECOEFF] = Mem$t[ycoeff+GS_SAVECOEFF] + yshift + +$if (datatype == r) + # Free original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore fit. + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + # Free original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore fit. + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + call sfree (sp) +end + + +$endfor diff --git a/pkg/images/immatch/src/geometry/geofunc.x b/pkg/images/immatch/src/geometry/geofunc.x new file mode 100644 index 00000000..c3be8fa5 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geofunc.x @@ -0,0 +1,340 @@ +include +include + + + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmagr (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +real xmag, ymag #I/O the x and y magnification +real xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_INDEFR(xmag)) + xmag = real (dtgetr (dt, rec, "xmag")) + if (IS_INDEFR(ymag)) + ymag = real (dtgetr (dt, rec, "ymag")) + if (IS_INDEFR(xrot)) + xrot = DEGTORAD (real(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_INDEFR(yrot)) + yrot = DEGTORAD (real (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmagr (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshiftr (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +real xout, yout #I the input coordinate system origin +real xref, yref #I the reference coordinate system origin +real xshift, yshift #I the origin shift in input coordinates + +real gsgetr(), gseval() + +begin + if (IS_INDEFR(xref)) + xref = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (IS_INDEFR(yref)) + yref = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMAX)) / 2.0 + + if (IS_INDEFR(xout)) + xout = gseval (sx1, xref, yref) + if (IS_INDEFR(yout)) + yout = gseval (sy1, xref, yref) + + if (IS_INDEFR(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_INDEFR(yshift)) + yshift = yout - gseval (sy1, xref, yref) + + call geo_xyshiftr (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmagr (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +real xscale, yscale #I the x and y scales +real xrotation,yrotation #I the x and y axis rotation angles in radians + +real cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +real gsgetr() +int gsgeti() + +begin + # Get the current solution. + call smark (sp) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Memr[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Memr[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Memr[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Memr[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = gsgetr (sx1, GSXMAX) - gsgetr (sx1, GSXMIN) + Memr[xcoeff+GS_SAVECOEFF+1] = Memr[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memr[xcoeff+GS_SAVECOEFF+2] = Memr[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = gsgetr (sy1, GSYMAX) - gsgetr (sy1, GSYMIN) + Memr[ycoeff+GS_SAVECOEFF+1] = Memr[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memr[ycoeff+GS_SAVECOEFF+2] = Memr[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + + # Free the original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore the edited fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshiftr (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +real xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +int gsgeti() + +begin + call smark (sp) + + # Allocate working space. + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + + # Get coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Shift the coefficients. + Memr[xcoeff+GS_SAVECOEFF] = Memr[xcoeff+GS_SAVECOEFF] + xshift + Memr[ycoeff+GS_SAVECOEFF] = Memr[ycoeff+GS_SAVECOEFF] + yshift + + # Free original fit. + call gsfree (sx1) + call gsfree (sy1) + + # Restore fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + call sfree (sp) +end + + + + +# GEO_DROTMAG -- Adjust the coefficients of the fit using the database file. + +procedure geo_drotmagd (dt, rec, sx1, sy1, xmag, ymag, xrot, yrot) + +pointer dt #I pointer to the text database file +int rec #I record number +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +double xmag, ymag #I/O the x and y magnification +double xrot, yrot #I/O the x and y axis rotation + +real dtgetr() + +begin + if (IS_INDEFD(xmag)) + xmag = double (dtgetr (dt, rec, "xmag")) + if (IS_INDEFD(ymag)) + ymag = double (dtgetr (dt, rec, "ymag")) + if (IS_INDEFD(xrot)) + xrot = DEGTORAD (double(dtgetr (dt, rec, "xrotation"))) + else + xrot = DEGTORAD(xrot) + if (IS_INDEFD(yrot)) + yrot = DEGTORAD (double (dtgetr (dt, rec, "yrotation"))) + else + yrot = DEGTORAD(yrot) + call geo_rotmagd (sx1, sy1, xmag, ymag, xrot, yrot) +end + + +# GEO_DXYSHIFT -- Adjust the fitted xy shift using the database file. + +procedure geo_dxyshiftd (dt, rec, sx1, sy1, xout, yout, xref, yref, + xshift, yshift) + +pointer dt #I pointer to the text file database +int rec #I the database record +pointer sx1, sy1 #I/O pointers to the x and y linear surfaces +double xout, yout #I the input coordinate system origin +double xref, yref #I the reference coordinate system origin +double xshift, yshift #I the origin shift in input coordinates + +double dgsgetd(), dgseval() + +begin + if (IS_INDEFD(xref)) + xref = (dgsgetd (sx1, GSXMIN) + dgsgetd (sx1, GSXMAX)) / 2.0d0 + if (IS_INDEFD(yref)) + yref = (dgsgetd (sy1, GSYMIN) + dgsgetd (sy1, GSYMAX)) / 2.0d0 + + if (IS_INDEFD(xout)) + xout = dgseval (sx1, xref, yref) + if (IS_INDEFD(yout)) + yout = dgseval (sy1, xref, yref) + + if (IS_INDEFD(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_INDEFD(yshift)) + yshift = yout - dgseval (sy1, xref, yref) + + call geo_xyshiftd (sx1, sy1, xshift, yshift) +end + + +# GEO_ROTMAG -- Edit the coefficients of the linear surface which determine +# magnification and rotation. + +procedure geo_rotmagd (sx1, sy1, xscale, yscale, xrotation, yrotation) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +double xscale, yscale #I the x and y scales +double xrotation,yrotation #I the x and y axis rotation angles in radians + +double cosx, sinx, cosy, siny, xrange, yrange +int ncoeff +pointer sp, xcoeff, ycoeff +double dgsgetd() +int dgsgeti() + +begin + # Get the current solution. + call smark (sp) + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Define the scaling parameters. + cosx = cos (xrotation) + sinx = sin (xrotation) + cosy = cos (yrotation) + siny = sin (yrotation) + + # Calculate coefficients. + Memd[xcoeff+GS_SAVECOEFF+1] = xscale * cosx + Memd[xcoeff+GS_SAVECOEFF+2] = yscale * siny + Memd[ycoeff+GS_SAVECOEFF+1] = -xscale * sinx + Memd[ycoeff+GS_SAVECOEFF+2] = yscale * cosy + + # Normalize coefficients for-non polynomial functions. + if (dgsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + xrange = dgsgetd (sx1, GSXMAX) - dgsgetd (sx1, GSXMIN) + Memd[xcoeff+GS_SAVECOEFF+1] = Memd[xcoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memd[xcoeff+GS_SAVECOEFF+2] = Memd[xcoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + if (dgsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + yrange = dgsgetd (sy1, GSYMAX) - dgsgetd (sy1, GSYMIN) + Memd[ycoeff+GS_SAVECOEFF+1] = Memd[ycoeff+GS_SAVECOEFF+1] * + xrange / 2.d0 + Memd[ycoeff+GS_SAVECOEFF+2] = Memd[ycoeff+GS_SAVECOEFF+2] * + yrange / 2.d0 + } + + # Free the original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore the edited fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + call sfree (sp) +end + + +# GEO_XYSHIFT -- Shift the linear part of the fit in x and y. + +procedure geo_xyshiftd (sx1, sy1, xshift, yshift) + +pointer sx1, sy1 #I pointers to linear x and y surfaces +double xshift, yshift #I the input x and y shifts + +int ncoeff +pointer sp, xcoeff, ycoeff +int dgsgeti() + +begin + call smark (sp) + + # Allocate working space. + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_DOUBLE) + call salloc (ycoeff, ncoeff, TY_DOUBLE) + + # Get coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + + # Shift the coefficients. + Memd[xcoeff+GS_SAVECOEFF] = Memd[xcoeff+GS_SAVECOEFF] + xshift + Memd[ycoeff+GS_SAVECOEFF] = Memd[ycoeff+GS_SAVECOEFF] + yshift + + # Free original fit. + call dgsfree (sx1) + call dgsfree (sy1) + + # Restore fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + call sfree (sp) +end + + + diff --git a/pkg/images/immatch/src/geometry/geotimtran.x b/pkg/images/immatch/src/geometry/geotimtran.x new file mode 100644 index 00000000..f84a794d --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotimtran.x @@ -0,0 +1,543 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "geotran.h" + +# GEO_IMTRAN -- Correct an entire image for geometric distortion using the +# transformed coordinates and image interpolation. + +procedure geo_imtran (input, output, geo, sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surface descriptors +pointer sx2, sy2 #I pointer to higher order surface descriptors + +int nincr +pointer sp, xref, yref, msi +real shift +real gsgetr() + +begin + # Initialize the interpolant and compute the out-of-bounds pixel + # margin required. + if (IM_NDIM(input) == 1) { + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift, 0.0) + } else { + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, nincr, shift, shift, 0.0) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Allocate working space. + call smark (sp) + call salloc (xref, GT_NCOLS(geo), TY_REAL) + call salloc (yref, GT_NLINES(geo), TY_REAL) + + # Calculate the reference coordinates of the input image pixels. + call geo_ref (geo, Memr[xref], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[yref], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + + # Configure the out-of-bounds pixel references for the input image. + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xref], + GT_NCOLS(geo), Memr[yref], GT_NLINES(geo)) + + # Interpolate. + call geo_gsvector (input, output, geo, msi, Memr[xref], 1, + GT_NCOLS(geo), Memr[yref], 1, GT_NLINES(geo), sx1, sy1, sx2, sy2) + + # Clean up. + if (IM_NDIM(input) == 1) + call asifree (msi) + else + call msifree (msi) + call sfree (sp) +end + + +# GEO_SIMTRAN -- Correct an entire image for geometric distortion using +# nterpolated coordinate surfaces to speed up computation of the transformed +# coordinates and image interpolation. + +procedure geo_simtran (input, output, geo, sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointer to linear surface descriptors +pointer sx2, sy2 #I pointer to higher order surface descriptors + +int nxsample, nysample, nincr +pointer sp, xsample, ysample, xinterp, yinterp +pointer xmsi, ymsi, jmsi, msi, xbuf, ybuf, jbuf +real shift +real gsgetr() + +begin + # Allocate working space and intialize the interpolant. + call smark (sp) + call salloc (xsample, GT_NCOLS(geo), TY_REAL) + call salloc (ysample, GT_NLINES(geo), TY_REAL) + call salloc (xinterp, GT_NCOLS(geo), TY_REAL) + call salloc (yinterp, GT_NLINES(geo), TY_REAL) + + # Set up sampling size. + if (GT_NCOLS(geo) == 1) + nxsample = 1 + else + nxsample = GT_NCOLS(geo) / GT_XSAMPLE(geo) + if (GT_NLINES(geo) == 1) + nysample = 1 + else + nysample = GT_NLINES(geo) / GT_YSAMPLE(geo) + + # Initialize interpolants. + if (IM_NDIM(input) == 1) { + call asiinit (xmsi, II_LINEAR) + call asiinit (ymsi, II_LINEAR) + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call asiinit (jmsi, II_LINEAR) + } else { + call msiinit (xmsi, II_BILINEAR) + call msiinit (ymsi, II_BILINEAR) + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, nincr, shift, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call msiinit (jmsi, II_BILINEAR) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Setup input image boundary extension parameters. + call geo_ref (geo, Memr[xsample], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[ysample], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xsample], + GT_NCOLS(geo), Memr[ysample], GT_NLINES(geo)) + + # Calculate the sampled reference coordinates and the interpolated + # reference coordinates. + call geo_ref (geo, Memr[xsample], 1, nxsample, nxsample, Memr[ysample], + 1, nysample, nysample, gsgetr (sx1, GSXMIN), gsgetr (sx1, GSXMAX), + gsgetr (sx1, GSYMIN), gsgetr (sx1, GSYMAX), GT_ONE) + call geo_sample (geo, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, GT_ONE) + + # Initialize the buffers + xbuf = NULL + ybuf = NULL + jbuf = NULL + + # Set up interpolants + call geo_xbuffer (sx1, sx2, xmsi, Memr[xsample], Memr[ysample], 1, + nxsample, 1, nysample, xbuf) + call geo_ybuffer (sy1, sy2, ymsi, Memr[xsample], Memr[ysample], 1, + nxsample, 1, nysample, ybuf) + if (GT_FLUXCONSERVE(geo) == YES && (sx2 != NULL || sy2 != NULL)) { + if (IM_NDIM(input) == 1) + call geo_jbuffer (sx1, NULL, sx2, NULL, jmsi, Memr[xsample], + Memr[ysample], 1, nxsample, 1, nysample, jbuf) + else + call geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, Memr[xsample], + Memr[ysample], 1, nxsample, 1, nysample, jbuf) + } + + # Transform the image. + call geo_msivector (input, output, geo, xmsi, ymsi, jmsi, msi, + sx1, sy1, sx2, sy2, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, 1, 1) + + # Free space. + if (IM_NDIM(input) == 1) { + call asifree (xmsi) + call asifree (ymsi) + call asifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call asifree (jmsi) + } else { + call msifree (xmsi) + call msifree (ymsi) + call msifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call msifree (jmsi) + } + call mfree (xbuf, TY_REAL) + call mfree (ybuf, TY_REAL) + if (jbuf != NULL) + call mfree (jbuf, TY_REAL) + call sfree (sp) +end + + +## GEO_IMSIVECTOR -- Evaluate the output image using interpolated surface +## coordinates. +# +#procedure geo_imsivector (in, out, geo, xmsi, ymsi, jmsi, msi, sx1, sy1, sx2, +# sy2, xref, yref, ncols, nlines) +# +#pointer in #I pointer to input image +#pointer out #I pointer to output image +#pointer geo #I pointer to geotran structure +#pointer xmsi, ymsi #I pointer to the interpolation xy surfaces +#pointer jmsi #I pointer to Jacobian surface +#pointer msi #I pointer to interpolation surface +#pointer sx1, sy1 #I linear surface descriptors +#pointer sx2, sy2 #I distortion surface pointers +#real xref[ARB] #I x reference coordinates +#real yref[ARB] #I y reference coordinates +#int ncols, nlines #I number of columns and rows +# +#int j +#pointer sp, x, y, xin, yin, xout, yout, inbuf, outbuf +#real factor +#pointer imgs1r(), imgs2r(), imps1r(), imps2r() +#real geo_jfactor() +# +#begin +# # Allocate working space. +# call smark (sp) +# call salloc (x, ncols, TY_REAL) +# call salloc (y, ncols, TY_REAL) +# call salloc (xin, ncols, TY_REAL) +# call salloc (yin, ncols, TY_REAL) +# call salloc (xout, ncols, TY_REAL) +# call salloc (yout, ncols, TY_REAL) +# +# # Fit the interpolant +# if (IM_NDIM(in) == 1) +# inbuf = imgs1r (in, 1, int (IM_LEN(in,1))) +# else +# inbuf = imgs2r (in, 1, int (IM_LEN(in,1)), 1, int (IM_LEN(in,2))) +# if (inbuf == EOF) +# call error (0, "Error reading image") +# if (IM_NDIM(in) == 1) +# call asifit (msi, Memr[inbuf], int (IM_LEN(in,1))) +# else +# call msifit (msi, Memr[inbuf], int (IM_LEN(in,1)), +# int (IM_LEN(in,2)), int (IM_LEN(in,1))) +# +# # Compute the output bufferr. +# do j = 1, nlines { +# +# # Compute coordinates. +# call amovkr (yref[j], Memr[y], ncols) +# if (IM_NDIM(in) == 1) { +# call asivector (xmsi, xref, Memr[xin], ncols) +# call asivector (ymsi, xref, Memr[yin], ncols) +# } else { +# call msivector (xmsi, xref, Memr[y], Memr[xin], ncols) +# call msivector (ymsi, xref, Memr[y], Memr[yin], ncols) +# } +# +# # Correct for out-of-bounds pixels. +# call geo_btran (in, geo, Memr[xin], Memr[yin], Memr[xout], +# Memr[yout], ncols) +# +# # Write to output image. +# if (IM_NDIM(in) == 1) +# outbuf = imps1r (out, 1, ncols) +# else +# outbuf = imps2r (out, 1, ncols, j, j) +# if (outbuf == EOF) +# call error (0, "Error writing output image") +# if (IM_NDIM(in) == 1) +# call asivector (msi, Memr[xout], Memr[outbuf], ncols) +# else +# call msivector (msi, Memr[xout], Memr[yout], Memr[outbuf], +# ncols) +# +# # Perform constant boundary extension. +# if (GT_BOUNDARY(geo) == BT_CONSTANT) +# call geo_bconstant (in, geo, Memr[xin], Memr[yin], +# Memr[outbuf], Memr[outbuf], ncols) +# +# # Preserve flux in image. +# if (GT_FLUXCONSERVE(geo) == YES) { +# factor = GT_XSCALE(geo) * GT_YSCALE(geo) +# if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == +# NULL)) { +# if (IM_NDIM(in) == 1) +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# NULL), Memr[outbuf], ncols) +# else +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# sy1), Memr[outbuf], ncols) +# } else { +# if (IM_NDIM(in) == 1) +# call geo_msiflux (jmsi, xref, yref, Memr[outbuf], +# 1, ncols, 0, 1, 1) +# else +# call geo_msiflux (jmsi, xref, yref, Memr[outbuf], +# 1, ncols, j, 1, 1) +# call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) +# } +# } +# } +# +# call sfree (sp) +#end + + +## GEO_IGSVECTOR -- Evaluate the output image using fitted coordinates. +# +#procedure geo_igsvector (input, output, geo, msi, xref, yref, ncols, nlines, +# sx1, sy1, sx2, sy2) +# +#pointer input #I pointer to input image +#pointer output #I pointer to output image +#pointer geo #I pointer to geotran structure +#pointer msi #I pointer to interpolant +#real xref[ARB] #I x reference array +#real yref[ARB] #I y reference array +#int ncols, nlines #I number of columns and lines +#pointer sx1, sy1 #I pointer to linear surface +#pointer sx2, sy2 #I pointer to distortion surface +# +#int j +#pointer sp, y, xin, yin, xout, yout, temp, inbuf, outbuf +#real factor +#pointer imgs1r(), imgs2r(), imps1r(), imps2r() +#real geo_jfactor() +# +#begin +# # Allocate working space. +# call smark (sp) +# call salloc (y, ncols, TY_REAL) +# call salloc (xin, ncols, TY_REAL) +# call salloc (yin, ncols, TY_REAL) +# call salloc (xout, ncols, TY_REAL) +# call salloc (yout, ncols, TY_REAL) +# call salloc (temp, ncols, TY_REAL) +# +# # Fill image buffer. +# if (IM_NDIM(input) == 1) +# inbuf = imgs1r (input, 1, int (IM_LEN(input,1))) +# else +# inbuf = imgs2r (input, 1, int (IM_LEN(input,1)), 1, +# int (IM_LEN(input,2))) +# if (inbuf == EOF) +# call error (0, "Error reading image") +# +# # Fit the interpolant. +# if (IM_NDIM(input) == 1) +# call asifit (msi, Memr[inbuf], int (IM_LEN(input,1))) +# else +# call msifit (msi, Memr[inbuf], int (IM_LEN(input,1)), +# int (IM_LEN(input,2)), int (IM_LEN(input,1))) +# +# # Calculate the x and y input image coordinates. +# do j = 1, nlines { +# +# # Get output image buffer. +# if (IM_NDIM(input) == 1) +# outbuf = imps1r (output, 1, ncols) +# else +# outbuf = imps2r (output, 1, ncols, j, j) +# if (output == EOF) +# call error (0, "Error writing output image") +# +# # Fit x coords. +# call amovkr (yref[j], Memr[y], ncols) +# call gsvector (sx1, xref, Memr[y], Memr[xin], ncols) +# if (sx2 != NULL) { +# call gsvector (sx2, xref, Memr[y], Memr[temp], ncols) +# call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) +# } +# +# # Fit y coords. +# call gsvector (sy1, xref, Memr[y], Memr[yin], ncols) +# if (sy2 != NULL) { +# call gsvector (sy2, xref, Memr[y], Memr[temp], ncols) +# call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) +# } +# +# # Compute of of bounds pixels. +# call geo_btran (input, geo, Memr[xin], Memr[yin], Memr[xout], +# Memr[yout], ncols) +# +# # Interpolate in input image. +# if (IM_NDIM(input) == 1) +# call asivector (msi, Memr[xout], Memr[outbuf], ncols) +# else +# call msivector (msi, Memr[xout], Memr[yout], Memr[outbuf], +# ncols) +# +# # Correct for constant boundary extension. +# if (GT_BOUNDARY(geo) == BT_CONSTANT) +# call geo_bconstant (input, geo, Memr[xin], Memr[yin], +# Memr[outbuf], Memr[outbuf], ncols) +# +# # Preserve flux in image. +# if (GT_FLUXCONSERVE(geo) == YES) { +# factor = GT_XSCALE(geo) * GT_YSCALE(geo) +# if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == +# NULL)) { +# if (IM_NDIM(input) == 1) +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# NULL), Memr[outbuf], ncols) +# else +# call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, +# sy1), Memr[outbuf], ncols) +# } else { +# if (IM_NDIM(input) == 1) +# call geo_gsflux (xref, yref, Memr[outbuf], 1, ncols, j, +# sx1, NULL, sx2, NULL) +# else +# call geo_gsflux (xref, yref, Memr[outbuf], 1, ncols, j, +# sx1, sy1, sx2, sy2) +# call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) +# } +# } +# } +# +# call sfree (sp) +#end + + +## GEO_BTRAN -- Map out-of-bounds pixel into the input image. +# +#procedure geo_btran (input, geo, xin, yin, xout, yout, ncols) +# +#pointer input #I pointer to the input image +#pointer geo #I pointer to geotran strcuture +#real xin[ARB] #I x input coords +#real yin[ARB] #I y input coords +#real xout[ARB] #O x output coords +#real yout[ARB] #O y output coords +#int ncols #I number of columns +# +#int i +#real xmax, ymax, xtemp, ytemp +# +#begin +# xmax = IM_LEN(input,1) +# if (IM_NDIM(input) == 1) +# ymax = 1.0 +# else +# ymax = IM_LEN(input,2) +# +# switch (GT_BOUNDARY(geo)) { +# case BT_CONSTANT, BT_NEAREST: +# do i = 1, ncols { +# if (xin[i] < 1.0) +# xout[i] = 1.0 +# else if (xin[i] > xmax) +# xout[i] = xmax +# else +# xout[i] = xin[i] +# if (yin[i] < 1.0) +# yout[i] = 1.0 +# else if (yin[i] > ymax) +# yout[i] = ymax +# else +# yout[i] = yin[i] +# } +# case BT_REFLECT: +# do i = 1, ncols { +# if (xin[i] < 1.0) +# xout[i] = 1.0 + (1.0 - xin[i]) +# else if (xin[i] > xmax) +# xout[i] = xmax - (xin[i] - xmax) +# else +# xout[i] = xin[i] +# if (yin[i] < 1.0) +# yout[i] = 1.0 + (1.0 - yin[i]) +# else if (yin[i] > ymax) +# yout[i] = ymax - (yin[i] - ymax) +# else +# yout[i] = yin[i] +# } +# case BT_WRAP: +# do i = 1, ncols { +# xtemp = xin[i] +# ytemp = yin[i] +# +# if (xtemp < 1.0) { +# while (xtemp < 1.0) +# xtemp = xtemp + xmax +# if (xtemp < 1.0) +# xtemp = xmax - xtemp +# else if (xtemp > xmax) +# xtemp = 2.0 + xmax - xtemp +# } else if (xtemp > xmax) { +# while (xtemp > xmax) +# xtemp = xtemp - xmax +# if (xtemp < 1.0) +# xtemp = xmax - xtemp +# else if (xtemp > xmax) +# xtemp = 2.0 + xmax - xtemp +# } +# xout[i] = xtemp +# +# if (ytemp < 1.0) { +# while (ytemp < 1.0) +# ytemp = ytemp + ymax +# if (ytemp < 1.0) +# ytemp = ymax - ytemp +# else if (ytemp > ymax) +# ytemp = 2.0 + ymax - ytemp +# } else if (ytemp > ymax) { +# while (ytemp > ymax) +# ytemp = ytemp - ymax +# if (ytemp < 1.0) +# ytemp = ymax - ytemp +# else if (ytemp > ymax) +# ytemp = 2.0 + ymax - ytemp +# } +# yout[i] = ytemp +# } +# } +#end + + +## GEO_BCONSTANT -- Map constant out-of-bounds pixels into the input image. +# +#procedure geo_bconstant (input, geo, xin, yin, inbuf, outbuf, ncols) +# +#pointer input #I pointer to the input image +#pointer geo #I pointer to geotran structure +#real xin[ARB] #I x input coords +#real yin[ARB] #I y input coords +#real inbuf[ARB] #I input buffer +#real outbuf[ARB] #O output buffer +#int ncols #I number of columns +# +#int i +#real xmax, ymax, constant +# +#begin +# xmax = IM_LEN(input,1) +# if (IM_NDIM(input) == 1) +# ymax = 1.0 +# else +# ymax = IM_LEN(input,2) +# constant = GT_CONSTANT(geo) +# do i = 1, ncols { +# if (xin[i] < 1.0 || xin[i] > xmax || yin[i] < 1.0 || yin[i] > ymax) +# outbuf[i] = constant +# else +# outbuf[i] = inbuf[i] +# } +#end diff --git a/pkg/images/immatch/src/geometry/geotran.h b/pkg/images/immatch/src/geometry/geotran.h new file mode 100644 index 00000000..d2fa6b55 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotran.h @@ -0,0 +1,52 @@ +# GEOTRAN Structure + +define LEN_GEOSTRUCT (30 + SZ_FNAME) + +# output picture formatting parameters + +define GT_NCOLS Memi[$1] # number of output columns +define GT_NLINES Memi[$1+1] # number of output lines +define GT_XMIN Memr[P2R($1+2)] # x minimum +define GT_XMAX Memr[P2R($1+3)] # x maximum +define GT_YMIN Memr[P2R($1+4)] # y minimun +define GT_YMAX Memr[P2R($1+5)] # y maximum +define GT_XSCALE Memr[P2R($1+6)] # x scale +define GT_YSCALE Memr[P2R($1+7)] # y scale + +# transformation parameters + +define GT_GEOMODE Memi[$1+8] # Type of transformation +define GT_XIN Memr[P2R($1+9)] # x input pixel +define GT_YIN Memr[P2R($1+10)] # y input pixel +define GT_XOUT Memr[P2R($1+11)] # x output pixel +define GT_YOUT Memr[P2R($1+12)] # y output pixel +define GT_XSHIFT Memr[P2R($1+13)] # x shift +define GT_YSHIFT Memr[P2R($1+14)] # y shift +define GT_XMAG Memr[P2R($1+15)] # input image x scale +define GT_YMAG Memr[P2R($1+16)] # input image y scale +define GT_XROTATION Memr[P2R($1+17)] # rotation angle +define GT_YROTATION Memr[P2R($1+18)] # scale angle + +# interpolation parameters +define GT_XSAMPLE Memr[P2R($1+19)] # x surface subsampling +define GT_YSAMPLE Memr[P2R($1+20)] # y surface subsampling +define GT_INTERPOLANT Memi[$1+21] # image interpolant +define GT_NSINC Memi[$1+22] # sinc width half-width +define GT_NXYMARGIN Memi[$1+23] # the interpolation margin +define GT_BOUNDARY Memi[$1+24] # boundary extension +define GT_CONSTANT Memr[P2R($1+25)] # constant boundary extension +define GT_FLUXCONSERVE Memi[$1+26] # conserve total flux +define GT_INTERPSTR Memc[P2C($1+27)] # interpolation string + +# GEOTRAN MODES + +define GT_NONE 1 # parameters defined by user +define GT_LINEAR 2 # use linear transformation +define GT_DISTORT 3 # distortion transformation only +define GT_GEOMETRIC 4 # use full transformation + +# GEOTRAN COORDINATE MODES + +define GT_ONE 1 +define GT_TWO 2 +define GT_FOUR 3 diff --git a/pkg/images/immatch/src/geometry/geotran.x b/pkg/images/immatch/src/geometry/geotran.x new file mode 100644 index 00000000..ee689d26 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geotran.x @@ -0,0 +1,1752 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "geotran.h" + +define NMARGIN 3 # number of boundary pixels +define NMARGIN_SPLINE3 16 # number of spline boundary pixels + +# GEO_TRAN -- Correct an image for geometric distortion block by block using +# fitted coordinates and image interpolation. + +procedure geo_tran (input, output, geo, sx1, sy1, sx2, sy2, nxblock, nyblock) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointers to higher order surfaces +int nxblock, nyblock #I working block size + +int l1, l2, c1, c2, nincr +pointer sp, xref, yref, msi +real shift +real gsgetr() + +begin + # Initialize the interpolant. + if (IM_NDIM(input) == 1) { + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), GT_NSINC(geo), + nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + shift, 0.0) + } else { + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + nincr, shift, shift, 0.0) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Allocate working space. + call smark (sp) + call salloc (xref, GT_NCOLS(geo), TY_REAL) + call salloc (yref, GT_NLINES(geo), TY_REAL) + + # Compute the reference coordinates corresponding to the center of + # the output image pixels. + call geo_ref (geo, Memr[xref], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[yref], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + + # Configure the out-of-bounds pixel references for the input image. + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xref], + GT_NCOLS(geo), Memr[yref], GT_NLINES(geo)) + + # Loop over the line blocks. + for (l1 = 1; l1 <= GT_NLINES(geo); l1 = l1 + nyblock) { + + # Set line limits in the output image. + l2 = min (l1 + nyblock - 1, GT_NLINES(geo)) + + # Loop over the column blocks + for (c1 = 1; c1 <= GT_NCOLS(geo); c1 = c1 + nxblock) { + + # Set column limits in the output image. + c2 = min (c1 + nxblock - 1, GT_NCOLS(geo)) + + # Interpolate + call geo_gsvector (input, output, geo, msi, Memr[xref], + c1, c2, Memr[yref], l1, l2, sx1, sy1, sx2, sy2) + } + } + + # Clean up. + if (IM_NDIM(input) == 1) + call asifree (msi) + else + call msifree (msi) + call sfree (sp) +end + + +# GEO_STRAN -- Correct an image for geometric distortion block by block using +# interpolated coordinates and image interpolation. + +procedure geo_stran (input, output, geo, sx1, sy1, sx2, sy2, nxblock, nyblock) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointers to higher order surfaces +int nxblock, nyblock #I working block size + +int nxsample, nysample, ncols, nlines, l1, l2, c1, c2 +int line1, line2, llast1, llast2, nincr +pointer sp, xsample, ysample, xinterp, yinterp +pointer xmsi, ymsi, jmsi, msi, xbuf, ybuf, jbuf +real shift +real gsgetr() + +begin + # Allocate working space and intialize the interpolant. + call smark (sp) + call salloc (xsample, GT_NCOLS(geo), TY_REAL) + call salloc (ysample, GT_NLINES(geo), TY_REAL) + call salloc (xinterp, GT_NCOLS(geo), TY_REAL) + call salloc (yinterp, GT_NLINES(geo), TY_REAL) + + # Compute the sample size. + if (GT_NCOLS(geo) == 1) + nxsample = 1 + else + nxsample = GT_NCOLS(geo) / GT_XSAMPLE(geo) + if (GT_NLINES(geo) == 1) + nysample = 1 + else + nysample = GT_NLINES(geo) / GT_YSAMPLE(geo) + + # Initialize interpolants. + if (IM_NDIM(input) == 1) { + call asiinit (xmsi, II_LINEAR) + call asiinit (ymsi, II_LINEAR) + call asitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call asisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call asiinit (jmsi, II_LINEAR) + } else { + call msiinit (xmsi, II_BILINEAR) + call msiinit (ymsi, II_BILINEAR) + call msitype (GT_INTERPSTR(geo), GT_INTERPOLANT(geo), + GT_NSINC(geo), nincr, shift) + call msisinit (msi, GT_INTERPOLANT(geo), GT_NSINC(geo), nincr, + nincr, shift, shift, 0.0) + if (GT_FLUXCONSERVE(geo) == YES) + call msiinit (jmsi, II_BILINEAR) + } + call geo_margset (sx1, sy1, sx2, sy2, GT_XMIN(geo), GT_XMAX(geo), + GT_NCOLS(geo), GT_YMIN(geo), GT_YMAX(geo), GT_NLINES(geo), + GT_INTERPOLANT(geo), GT_NSINC(geo), GT_NXYMARGIN(geo)) + + # Setup input image boundary extension parameters. + call geo_ref (geo, Memr[xsample], 1, GT_NCOLS(geo), GT_NCOLS(geo), + Memr[ysample], 1, GT_NLINES(geo), GT_NLINES(geo), gsgetr (sx1, + GSXMIN), gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_ONE) + call geo_imset (input, geo, sx1, sy1, sx2, sy2, Memr[xsample], + GT_NCOLS(geo), Memr[ysample], GT_NLINES(geo)) + + # Calculate the sampled reference coordinates and the interpolated + # reference coordinates. + call geo_ref (geo, Memr[xsample], 1, nxsample, nxsample, Memr[ysample], + 1, nysample, nysample, gsgetr (sx1, GSXMIN), gsgetr (sx1, GSXMAX), + gsgetr (sx1, GSYMIN), gsgetr (sx1, GSYMAX), GT_ONE) + call geo_sample (geo, Memr[xinterp], 1, GT_NCOLS(geo), nxsample, + Memr[yinterp], 1, GT_NLINES(geo), nysample, GT_ONE) + + # Initialize the buffers. + xbuf = NULL + ybuf = NULL + jbuf = NULL + + # Loop over the line blocks. + for (l1 = 1; l1 <= GT_NLINES(geo); l1 = l1 + nyblock) { + + # Set line limits in the output image. + l2 = min (l1 + nyblock - 1, GT_NLINES(geo)) + nlines = l2 - l1 + 1 + + # Line1 and line2 are the coordinates in the interpolation surface + line1 = max (1, min (nysample - 1, int (Memr[yinterp+l1-1]))) + line2 = min (nysample, int (Memr[yinterp+l2-1] + 1.0)) + + if ((xbuf == NULL) || (ybuf == NULL) || (jbuf == NULL) || + (line1 < llast1) || (line2 > llast2)) { + call geo_xbuffer (sx1, sx2, xmsi, Memr[xsample], Memr[ysample], + 1, nxsample, line1, line2, xbuf) + call geo_ybuffer (sy1, sy2, ymsi, Memr[xsample], Memr[ysample], + 1, nxsample, line1, line2, ybuf) + if (GT_FLUXCONSERVE(geo) == YES) { + if (IM_NDIM(input) == 1) + call geo_jbuffer (sx1, NULL, sx2, NULL, jmsi, + Memr[xsample], Memr[ysample], 1, nxsample, + line1, line2, jbuf) + else + call geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, + Memr[xsample], Memr[ysample], 1, nxsample, + line1, line2, jbuf) + } + llast1 = line1 + llast2 = line2 + } + + + # Loop over the column blocks. + for (c1 = 1; c1 <= GT_NCOLS(geo); c1 = c1 + nxblock) { + + # C1 and c2 are the column limits in the output image. + c2 = min (c1 + nxblock - 1, GT_NCOLS(geo)) + ncols = c2 - c1 + 1 + + # Calculate the coordinates of the output pixels in the input + # image. + call geo_msivector (input, output, geo, xmsi, ymsi, jmsi, msi, + sx1, sy1, sx2, sy2, Memr[xinterp], c1, c2, nxsample, + Memr[yinterp], l1, l2, nysample, 1, line1) + } + } + + # Free space. + if (IM_NDIM(input) == 1) { + call asifree (xmsi) + call asifree (ymsi) + call asifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call asifree (jmsi) + } else { + call msifree (xmsi) + call msifree (ymsi) + call msifree (msi) + if (GT_FLUXCONSERVE(geo) == YES) + call msifree (jmsi) + } + call mfree (xbuf, TY_REAL) + call mfree (ybuf, TY_REAL) + if (GT_FLUXCONSERVE(geo) == YES) + call mfree (jbuf, TY_REAL) + call sfree (sp) +end + + +# GEO_REF -- Determine the x and y coordinates at which the coordinate +# surface will be subsampled. + +procedure geo_ref (geo, x, c1, c2, nx, y, l1, l2, ny, xmin, xmax, ymin, ymax, + cmode) + +pointer geo #I pointer to the geotran structure +real x[ARB] #O output x sample coordinates +int c1, c2, nx #I the column limits of the sampled array +real y[ARB] #O output y sample coordinates +int l1, l2, ny #I the line limits of the output coordinates +real xmin, xmax #I limits on x coordinates +real ymin, ymax #I limits on y coordinates +int cmode #I coordinate computation mode + +int i +real xtempmin, xtempmax, ytempmin, ytempmax, dx, dy + +begin + + switch (cmode) { + case GT_FOUR: + if (nx == 1) { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo))) + xtempmax = min (xmax, max (xmin, GT_XMAX(geo))) + x[1] = xtempmin + x[2] = xtempmax + x[3] = xtempmax + x[4] = xtempmin + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[4*(i-c1)+1] = xtempmin + x[4*(i-c1)+2] = xtempmax + x[4*(i-c1)+3] = xtempmax + x[4*(i-c1)+4] = xtempmin + } + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[4*(i-c1)+1] = xtempmin + x[4*(i-c1)+2] = xtempmax + x[4*(i-c1)+3] = xtempmax + x[4*(i-c1)+4] = xtempmin + } + } + + case GT_TWO: + if (nx == 1) { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo))) + xtempmax = min (xmax, max (xmin, GT_XMAX(geo))) + x[1] = xtempmin + x[2] = xtempmax + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[2*(i-c1)+1] = xtempmin + x[2*(i-c1)+2] = xtempmax + } + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 { + xtempmin = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1.5) * dx)) + xtempmax = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 0.5) * dx)) + x[2*(i-c1)+1] = xtempmin + x[2*(i-c1)+2] = xtempmax + } + } + + case GT_ONE: + if (nx == 1) { + x[1] = min (xmax, max (xmin, + (GT_XMIN(geo) + GT_XMAX(geo)) / 2.0)) + } else if (nx == GT_NCOLS(geo)) { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) + else + dx = GT_XSCALE(geo) + do i = c1, c2 + x[i-c1+1] = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1) * dx)) + } else { + if (GT_XMIN(geo) > GT_XMAX(geo)) + dx = -GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + else + dx = GT_XSCALE(geo) * (GT_NCOLS(geo) - 1.0) / (nx - 1.0) + do i = c1, c2 + x[i-c1+1] = min (xmax, max (xmin, GT_XMIN(geo) + + (i - 1) * dx)) + } + + } + + switch (cmode) { + case GT_FOUR: + if (ny == 1) { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo))) + ytempmax = min (ymax, max (ymin, GT_YMAX(geo))) + y[1] = ytempmin + y[2] = ytempmin + y[3] = ytempmax + y[4] = ytempmax + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[4*(i-l1)+1] = ytempmin + y[4*(i-l1)+2] = ytempmin + y[4*(i-l1)+3] = ytempmax + y[4*(i-l1)+4] = ytempmax + } + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[4*(i-l1)+1] = ytempmin + y[4*(i-l1)+2] = ytempmin + y[4*(i-l1)+3] = ytempmax + y[4*(i-l1)+4] = ytempmax + } + } + + case GT_TWO: + if (ny == 1) { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo))) + ytempmax = min (ymax, max (ymin, GT_YMAX(geo))) + y[1] = ytempmin + y[2] = ytempmax + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[2*(i-l1)+1] = ytempmin + y[2*(i-l1)+2] = ytempmax + } + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 { + ytempmin = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1.5) * dy)) + ytempmax = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 0.5) * dy)) + y[2*(i-l1)+1] = ytempmin + y[2*(i-l1)+2] = ytempmax + } + } + case GT_ONE: + if (ny == 1) { + y[1] = min (ymax, max (ymin, + (GT_YMIN(geo) + GT_YMAX(geo)) / 2.0)) + } else if (ny == GT_NLINES(geo)) { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) + else + dy = GT_YSCALE(geo) + do i = l1, l2 + y[i-l1+1] = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1) * dy)) + } else { + if (GT_YMIN(geo) > GT_YMAX(geo)) + dy = -GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + else + dy = GT_YSCALE(geo) * (GT_NLINES(geo) - 1.0) / (ny - 1.0) + do i = l1, l2 + y[i-l1+1] = min (ymax, max (ymin, GT_YMIN(geo) + + (i - 1) * dy)) + } + + } +end + + +# GEO_SAMPLE -- Calculate the sampled reference points. + +procedure geo_sample (geo, xref, c1, c2, nxsample, yref, l1, l2, nysample, + cmode) + +pointer geo #I pointer to geotran structure +real xref[ARB] #O x reference values +int c1, c2, nxsample #I limits and number of sample points in x +real yref[ARB] #O y reference values +int l1, l2, nysample #I limits and number of sample points in y +int cmode #I coordinate computation mode + +int i +real xtempmin, xtempmax, ytempmin, ytempmax + +begin + switch (cmode) { + case GT_FOUR: + if (GT_NCOLS(geo) == 1) { + xref[1] = 0.5 + xref[2] = 1.5 + xref[3] = 1.5 + xref[4] = 0.5 + } else { + do i = c1, c2 { + xtempmin = min (real (nxsample), max (1., + real ((nxsample - 1) * (i - 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xtempmax = min (real (nxsample), max (1., + real ((nxsample - 1) * (i + 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xref[4*(i-c1)+1] = xtempmin + xref[4*(i-c1)+2] = xtempmax + xref[4*(i-c1)+3] = xtempmax + xref[4*(i-c1)+4] = xtempmin + } + + } + case GT_TWO: + if (GT_NCOLS(geo) == 1) { + xref[1] = 0.5 + xref[2] = 1.5 + } else { + do i = c1, c2 { + xtempmin = min (real (nxsample), max (1., + real ((nxsample - 1) * (i - 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xtempmax = min (real (nxsample), max (1., + real ((nxsample - 1) * (i + 0.5) + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + xref[2*(i-c1)+1] = xtempmin + xref[2*(i-c1)+2] = xtempmax + } + } + case GT_ONE: + if (GT_NCOLS(geo) == 1) + xref[1] = 1.0 + else { + do i = c1, c2 + xref[i-c1+1] = min (real (nxsample), max (1., + real ((nxsample - 1) * i + (GT_NCOLS(geo) - + nxsample)) / (GT_NCOLS(geo) - 1))) + } + } + + switch (cmode) { + case GT_FOUR: + if (GT_NLINES(geo) == 1) { + yref[1] = 0.5 + yref[2] = 0.5 + yref[3] = 1.5 + yref[4] = 1.5 + } else { + do i = l1, l2 { + ytempmin = min (real (nysample), max (1., + real ((nysample - 1) * (i - 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + ytempmax = min (real (nysample), max (1., + real ((nysample - 1) * (i + 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + yref[4*(i-l1)+1] = ytempmin + yref[4*(i-l1)+2] = ytempmin + yref[4*(i-l1)+3] = ytempmax + yref[4*(i-l1)+4] = ytempmax + } + } + case GT_TWO: + if (GT_NLINES(geo) == 1) { + yref[1] = 0.5 + yref[2] = 1.5 + } else { + do i = l1, l2 { + ytempmin = min (real (nysample), max (1., + real ((nysample - 1) * (i - 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + ytempmax = min (real (nysample), max (1., + real ((nysample - 1) * (i + 0.5) + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + yref[2*(i-l1)+1] = ytempmin + yref[2*(i-l1)+2] = ytempmax + } + } + case GT_ONE: + if (GT_NLINES(geo) == 1) + yref[1] = 1.0 + else { + do i = l1, l2 + yref[i-l1+1] = min (real (nysample), max (1., + real ((nysample - 1) * i + (GT_NLINES(geo) - + nysample)) / (GT_NLINES(geo) - 1))) + } + } +end + + +# GEO_XBUFFER -- Compute the x interpolant and coordinates. + +procedure geo_xbuffer (s1, s2, msi, xsample, ysample, c1, c2, l1, l2, buf) + +pointer s1, s2 #I pointers to the x surface +pointer msi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer buf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sf, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (s2 == NULL) + call gscopy (s1, sf) + else + call gsadd (s1, s2, sf) + + # Allocate working space. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute the coordinates. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (msi, Memr[buf], ncols) + else + call msifit (msi, Memr[buf], ncols, nlines, ncols) + + call gsfree (sf) + call sfree (sp) +end + + +# GEO_YBUFFER -- Compute the y interpolant and coordinates. + +procedure geo_ybuffer (s1, s2, msi, xsample, ysample, c1, c2, l1, l2, buf) + +pointer s1, s2 #I pointers to the y surface +pointer msi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer buf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sf, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (s2 == NULL) + call gscopy (s1, sf) + else + call gsadd (s1, s2, sf) + + # Allocate working space. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute the coordinates. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call gsvector (sf, xsample[c1], Memr[y], Memr[buf1], ncols) + } + buf2 = buf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (msi, Memr[buf], ncols) + else + call msifit (msi, Memr[buf], ncols, nlines, ncols) + + call gsfree (sf) + call sfree (sp) +end + + +# GEO_JBUFFER -- Fit the jacobian surface. + +procedure geo_jbuffer (sx1, sy1, sx2, sy2, jmsi, xsample, ysample, c1, c2, l1, + l2, jbuf) + +pointer sx1, sy1 #I pointers to the linear surfaces +pointer sx2, sy2 #I pointers to the distortion surfaces +pointer jmsi #I interpolant +real xsample[ARB] #I sampled x reference coordinates +real ysample[ARB] #I sampled y reference coordinates +int c1, c2 #I columns of interest in sampled image +int l1, l2 #I lines of interest in the sampled image +pointer jbuf #I pointer to output buffer + +int i, ncols, nlines, llast1, llast2, nclast, nllast +pointer sp, sx, sy, y, z, buf1, buf2 + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Combine surfaces. + if (sx2 == NULL) + call gscopy (sx1, sx) + else + call gsadd (sx1, sx2, sx) + if (sy1 == NULL) + sy = NULL + else if (sy2 == NULL) + call gscopy (sy1, sy) + else + call gsadd (sy1, sy2, sy) + + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (z, ncols, TY_REAL) + + # If buffer undefined then allocate memory for the buffer. Reallocate + # the buffer if the number of lines or columns changes. + if (jbuf == NULL) { + call malloc (jbuf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (jbuf, ncols * nlines, TY_REAL) + llast1 = l1 - nlines + llast2 = l2 - nlines + } + + # Compute surface. + if (l1 < llast1) { + do i = l2, l1, -1 { + if (i > llast1) + buf1 = jbuf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call geo_jgsvector (sx, sy, xsample[c1], Memr[y], + Memr[buf1], ncols) + } + buf2 = jbuf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (l2 > llast2) { + do i = l1, l2 { + if (i < llast2) + buf1 = jbuf + (i - llast1) * ncols + else { + buf1 = z + call amovkr (ysample[i], Memr[y], ncols) + call geo_jgsvector (sx, sy, xsample[c1], Memr[y], + Memr[buf1], ncols) + } + buf2 = jbuf + (i - l1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + # Update buffer pointers. + llast1 = l1 + llast2 = l2 + nclast = ncols + nllast = nlines + + # Fit the interpolant. + if (nlines == 1) + call asifit (jmsi, Memr[jbuf], ncols) + else + call msifit (jmsi, Memr[jbuf], ncols, nlines, ncols) + + call gsfree (sx) + call gsfree (sy) + call sfree (sp) +end + + +# GEO_JGSVECTOR -- Procedure to compute the Jacobian of the transformation. + +procedure geo_jgsvector (sx, sy, x, y, out, ncols) + +pointer sx, sy #I surface descriptors +real x[ARB] #I x values +real y[ARB] #I y values +real out[ARB] #O output values +int ncols #I number of points + +pointer sp, der1, der2 + +begin + call smark (sp) + + if (sy == NULL) { + call gsder (sx, x, y, out, ncols, 1, 0) + } else { + call salloc (der1, ncols, TY_REAL) + call salloc (der2, ncols, TY_REAL) + call gsder (sx, x, y, Memr[der1], ncols, 1, 0) + call gsder (sy, x, y, Memr[der2], ncols, 0, 1) + call amulr (Memr[der1], Memr[der2], out, ncols) + call gsder (sx, x, y, Memr[der1], ncols, 0, 1) + call gsder (sy, x, y, Memr[der2], ncols, 1, 0) + call amulr (Memr[der1], Memr[der2], Memr[der1], ncols) + call asubr (out, Memr[der1], out, ncols) + } + + call sfree (sp) +end + + +# GEO_MSIVECTOR -- Procedure to interpolate the surface coordinates + +procedure geo_msivector (in, out, geo, xmsi, ymsi, jmsi, msi, sx1, sy1, sx2, + sy2, xref, c1, c2, nxsample, yref, l1, l2, nysample, x0, y0) + +pointer in #I pointer to input image +pointer out #I pointer to output image +pointer geo #I pointer to geotran structure +pointer xmsi, ymsi #I pointer to the interpolation cord surfaces +pointer jmsi #I pointer to Jacobian surface +pointer msi #I pointer to interpolation surface +pointer sx1, sy1 #I pointers to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +real xref[ARB] #I x reference coordinates +int c1, c2 #I column limits in output image +int nxsample #I the x sample size +real yref[ARB] #I y reference coordinates +int l1, l2 #I line limits in output image +int nysample #I the y sample size +int x0, y0 #I zero points of interpolation coordinates + +int j, ncols, nlines, ncols4, nlines4 +int imc1, imc2, iml1, iml2, nicols, nilines +pointer sp, txref, tyref, x, y, xin, yin, inbuf, outbuf +real xmin, xmax, ymin, ymax, factor +pointer imgs1r(), imgs2r(), imps1r(), imps2r() +real geo_jfactor() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Find min max of interpolation coords. + if (IM_NDIM(in) == 1) + call geo_iminmax (xref, yref, c1, c2, l1, l2, x0, 0, + xmsi, ymsi, xmin, xmax, ymin, ymax) + else + call geo_iminmax (xref, yref, c1, c2, l1, l2, x0, y0, + xmsi, ymsi, xmin, xmax, ymin, ymax) + + # Get the appropriate image section and fit the interpolant. + imc1 = int(xmin) - GT_NXYMARGIN(geo) + if (imc1 <= 0) + imc1 = imc1 - 1 + imc2 = nint (xmax) + GT_NXYMARGIN(geo) + 1 + nicols = imc2 - imc1 + 1 + if (IM_NDIM(in) == 1) { + ncols4 = 2 * ncols + nlines4 = 2 * nlines + iml1 = 1 + iml2 = 1 + nilines = 1 + inbuf = imgs1r (in, imc1, imc2) + if (inbuf == EOF) + call error (0, "Error reading image") + call asifit (msi, Memr[inbuf], nicols) + } else { + ncols4 = 4 * ncols + nlines4 = 4 * nlines + iml1 = int(ymin) - GT_NXYMARGIN(geo) + if (iml1 <= 0) + iml1 = iml1 - 1 + iml2 = nint (ymax) + GT_NXYMARGIN(geo) + 1 + nilines = iml2 - iml1 + 1 + inbuf = imgs2r (in, imc1, imc2, iml1, iml2) + if (inbuf == EOF) + call error (0, "Error reading image") + call msifit (msi, Memr[inbuf], nicols, nilines, nicols) + } + + # Allocate working space. + call smark (sp) + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + call salloc (txref, ncols4, TY_REAL) + call salloc (tyref, nlines4, TY_REAL) + call salloc (x, ncols4, TY_REAL) + call salloc (y, ncols4, TY_REAL) + call salloc (xin, ncols4, TY_REAL) + call salloc (yin, ncols4, TY_REAL) + if (IM_NDIM(in) == 1) + call geo_sample (geo, Memr[txref], c1, c2, nxsample, + Memr[tyref], l1, l2, nysample, GT_TWO) + else + call geo_sample (geo, Memr[txref], c1, c2, nxsample, + Memr[tyref], l1, l2, nysample, GT_FOUR) + call aaddkr (Memr[txref], real (-x0 + 1), Memr[x], ncols4) + } else { + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call aaddkr (xref[c1], real (-x0 + 1), Memr[x], ncols) + } + + # Compute the output buffer. + do j = l1, l2 { + + # Write the output image. + if (IM_NDIM(in) == 1) + outbuf = imps1r (out, c1, c2) + else + outbuf = imps2r (out, c1, c2, j, j) + if (outbuf == EOF) + call error (0, "Error writing output image") + + # Compute the interpolation coordinates. + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + if (IM_NDIM(in) == 1) { + call asivector (xmsi, Memr[x], Memr[xin], ncols4) + call amovkr (1.0, Memr[yin], ncols4) + } else { + #call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call geo_repeat (Memr[tyref+4*(j-l1)], 4, Memr[y], ncols) + call aaddkr (Memr[y], real(-y0 + 1), Memr[y], ncols4) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols4) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols4) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols4) + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols4) + } else { + if (IM_NDIM(in) == 1) { + call asivector (xmsi, Memr[x], Memr[xin], ncols) + call amovkr (1.0, Memr[yin], ncols) + } else { + call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols) + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols) + } + + # Interpolate in the input image. + if (IM_NDIM(in) == 1) + call asivector (msi, Memr[xin], Memr[outbuf], ncols) + else + call msivector (msi, Memr[xin], Memr[yin], Memr[outbuf], ncols) + + # Preserve flux in image. + if (GT_FLUXCONSERVE(geo) == YES) { + factor = GT_XSCALE(geo) * GT_YSCALE(geo) + if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == + NULL)) { + if (IM_NDIM(in) == 1) + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + NULL), Memr[outbuf], ncols) + else + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + sy1), Memr[outbuf], ncols) + } else { + if (IM_NDIM(in) == 1) + call geo_msiflux (jmsi, xref, yref, Memr[outbuf], + c1, c2, 0, x0, y0) + else + call geo_msiflux (jmsi, xref, yref, Memr[outbuf], + c1, c2, j, x0, y0) + call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) + } + } + } + + call sfree (sp) +end + + +# GEO_GSVECTOR -- Evaluate the output image pixels using fitted coordinate +# values and image interpolation. + +procedure geo_gsvector (input, output, geo, msi, xref, c1, c2, yref, l1, l2, + sx1, sy1, sx2, sy2) + +pointer input #I pointer to input image +pointer output #I pointer to output image +pointer geo #I pointer to geotran structure +pointer msi #I pointer to interpolant +real xref[ARB] #I x reference array +int c1, c2 #I columns of interest in output image +real yref[ARB] #I y reference array +int l1, l2 #I lines of interest in the output image +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors + +int j, ncols, nlines, ncols4, nlines4, nicols, nilines +int imc1, imc2, iml1, iml2 +pointer sp, txref, tyref, y, xin, yin, temp, inbuf, outbuf +real xmin, xmax, ymin, ymax, factor +pointer imgs1r(), imgs2r(), imps1r(), imps2r() +real gsgetr(), geo_jfactor() + +begin + # Compute the number of columns. + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Compute the maximum and minimum coordinates. + call geo_minmax (xref, yref, c1, c2, l1, l2, sx1, sy1, sx2, sy2, + xmin, xmax, ymin, ymax) + + # Get the appropriate image section and fill the buffer. + imc1 = int(xmin) - GT_NXYMARGIN(geo) + if (imc1 <= 0) + imc1 = imc1 - 1 + imc2 = nint (xmax) + GT_NXYMARGIN(geo) + 1 + nicols = imc2 - imc1 + 1 + if (IM_NDIM(input) == 1) { + iml1 = 1 + iml2 = 1 + nilines = 1 + ncols4 = 2 * ncols + nlines4 = 2 * nlines + inbuf = imgs1r (input, imc1, imc2) + if (inbuf == EOF) + call error (0, "Error reading image") + call asifit (msi, Memr[inbuf], nicols) + } else { + iml1 = int(ymin) - GT_NXYMARGIN(geo) + if (iml1 <= 0) + iml1 = iml1 - 1 + iml2 = nint (ymax) + GT_NXYMARGIN(geo) + 1 + nilines = iml2 - iml1 + 1 + ncols4 = 4 * ncols + nlines4 = 4 * nlines + inbuf = imgs2r (input, imc1, imc2, iml1, iml2) + if (inbuf == EOF) + call error (0, "Error reading image") + call msifit (msi, Memr[inbuf], nicols, nilines, nicols) + } + + # Allocate working space. + call smark (sp) + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + call salloc (txref, ncols4, TY_REAL) + call salloc (tyref, nlines4, TY_REAL) + call salloc (y, ncols4, TY_REAL) + call salloc (xin, ncols4, TY_REAL) + call salloc (yin, ncols4, TY_REAL) + call salloc (temp, ncols4, TY_REAL) + if (IM_NDIM(input) == 1) + call geo_ref (geo, Memr[txref], c1, c2, GT_NCOLS(geo), + Memr[tyref], l1, l2, GT_NLINES(geo), gsgetr (sx1, GSXMIN), + gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_TWO) + else + call geo_ref (geo, Memr[txref], c1, c2, GT_NCOLS(geo), + Memr[tyref], l1, l2, GT_NLINES(geo), gsgetr (sx1, GSXMIN), + gsgetr (sx1, GSXMAX), gsgetr (sx1, GSYMIN), gsgetr (sx1, + GSYMAX), GT_FOUR) + } else { + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call salloc (temp, ncols, TY_REAL) + } + + # Compute the pixels. + do j = l1, l2 { + + # Get output image buffer. + if (IM_NDIM(input) == 1) + outbuf = imps1r (output, c1, c2) + else + outbuf = imps2r (output, c1, c2, j, j) + if (output == EOF) + call error (0, "Error writing output image") + + # Compute the interpolation coordinates. + if (GT_INTERPOLANT(geo) == II_DRIZZLE || GT_INTERPOLANT(geo) == + II_BIDRIZZLE) { + + # Set the y coordinate. + if (IM_NDIM(input) == 1) + call geo_repeat (Memr[tyref+2*(j-l1)], 2, Memr[y], ncols) + else + call geo_repeat (Memr[tyref+4*(j-l1)], 4, Memr[y], ncols) + + # Fit x coords. + call gsvector (sx1, Memr[txref], Memr[y], Memr[xin], ncols4) + if (sx2 != NULL) { + call gsvector (sx2, Memr[txref], Memr[y], Memr[temp], + ncols4) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols4) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols4) + + # Fit y coords. + call gsvector (sy1, Memr[txref], Memr[y], Memr[yin], ncols4) + if (sy2 != NULL) { + call gsvector (sy2, Memr[txref], Memr[y], Memr[temp], + ncols4) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols4) + } + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols4) + + } else { + + # Set the y coordinate. + call amovkr (yref[j], Memr[y], ncols) + + # Fit x coords. + call gsvector (sx1, xref[c1], Memr[y], Memr[xin], ncols) + if (sx2 != NULL) { + call gsvector (sx2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) + } + if (imc1 != 1) + call aaddkr (Memr[xin], real (-imc1 + 1), Memr[xin], ncols) + + # Fit y coords. + call gsvector (sy1, xref[c1], Memr[y], Memr[yin], ncols) + if (sy2 != NULL) { + call gsvector (sy2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) + } + if (iml1 != 1) + call aaddkr (Memr[yin], real (-iml1 + 1), Memr[yin], ncols) + } + + # Interpolate in input image. + if (IM_NDIM(input) == 1) + call asivector (msi, Memr[xin], Memr[outbuf], ncols) + else + call msivector (msi, Memr[xin], Memr[yin], Memr[outbuf], ncols) + + # Preserve flux in image. + if (GT_FLUXCONSERVE(geo) == YES) { + factor = GT_XSCALE(geo) * GT_YSCALE(geo) + if (GT_GEOMODE(geo) == GT_LINEAR || (sx2 == NULL && sy2 == + NULL)) { + if (IM_NDIM(input) == 1) + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + NULL), Memr[outbuf], ncols) + else + call amulkr (Memr[outbuf], factor * geo_jfactor (sx1, + sy1), Memr[outbuf], ncols) + } else { + if (IM_NDIM(input) == 1) + call geo_gsflux (xref, yref, Memr[outbuf], c1, c2, j, + sx1, NULL, sx2, NULL) + else + call geo_gsflux (xref, yref, Memr[outbuf], c1, c2, j, + sx1, sy1, sx2, sy2) + call amulkr (Memr[outbuf], factor, Memr[outbuf], ncols) + } + } + } + + call sfree (sp) +end + + +# GEO_IMINMAX -- Find minimum and maximum interpolation coordinates. + +procedure geo_iminmax (xref, yref, c1, c2, l1, l2, x0, y0, xmsi, ymsi, xmin, + xmax, ymin, ymax) + +real xref[ARB] #I x reference coords +real yref[ARB] #I y reference coords +int c1, c2 #I columns limits +int l1, l2 #I line limits +int x0, y0 #I interpolation coord zero points +pointer xmsi, ymsi #I coord surfaces +real xmin, xmax #O output xmin and xmax +real ymin, ymax #O output ymin and ymax + +int j, ncols +pointer sp, x, y, xin, yin +real mintemp, maxtemp, x1, x2, y1, y2 +real asieval(), msieval() + +begin + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (x, ncols, TY_REAL) + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + + xmin = MAX_REAL + xmax = -MAX_REAL + ymin = MAX_REAL + ymax = -MAX_REAL + + # find the minimum and maximum + do j = l1, l2 { + + if (j == l1 || j == l2) { + + call aaddkr (xref[c1], real (-x0 + 1), Memr[x], ncols) + if (y0 <= 0) { + call asivector (xmsi, Memr[x], Memr[xin], ncols) + ymin = 1.0 + ymax = 1.0 + } else { + call amovkr (yref[j] + real (-y0 + 1), Memr[y], ncols) + call msivector (xmsi, Memr[x], Memr[y], Memr[xin], ncols) + call msivector (ymsi, Memr[x], Memr[y], Memr[yin], ncols) + call alimr (Memr[yin], ncols, mintemp, maxtemp) + ymin = min (ymin, mintemp) + ymax = max (ymax, maxtemp) + } + call alimr (Memr[xin], ncols, mintemp, maxtemp) + xmin = min (xmin, mintemp) + xmax = max (xmax, maxtemp) + } else { + if (y0 <= 0) { + x1 = asieval (xmsi, xref[c1] + real (-x0 + 1)) + x2 = asieval (xmsi, xref[c1+ncols-1] + real (-x0 + 1)) + ymin = 1.0 + ymax = 1.0 + } else { + x1 = msieval (xmsi, xref[c1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + x2 = msieval (xmsi, xref[c1+ncols-1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + y1 = msieval (ymsi, xref[c1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + y2 = msieval (ymsi, xref[c1+ncols-1] + real (-x0 + 1), + yref[j] + real (-y0 + 1)) + ymin = min (ymin, y1, y2) + ymax = max (ymax, y1, y2) + } + xmin = min (xmin, x1, x2) + xmax = max (xmax, x1, x2) + + } + } + + call sfree (sp) + +end + + +# GEO_MINMAX -- Compute the minimum and maximum fitted coordinates. + +procedure geo_minmax (xref, yref, c1, c2, l1, l2, sx1, sy1, sx2, sy2, + xmin, xmax, ymin, ymax) + +real xref[ARB] #I x reference coords +real yref[ARB] #I y reference coords +int c1, c2 #I columns limits +int l1, l2 #I line limits +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xmin, xmax #O output xmin and xmax +real ymin, ymax #O output ymin and ymax + +int j, ncols +pointer sp, y, xin, yin, temp +real x1, x2, y1, y2, mintemp, maxtemp +real gseval() + +begin + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (y, ncols, TY_REAL) + call salloc (xin, ncols, TY_REAL) + call salloc (yin, ncols, TY_REAL) + call salloc (temp, ncols, TY_REAL) + + xmin = MAX_REAL + xmax = -MAX_REAL + ymin = MAX_REAL + ymax = -MAX_REAL + + # Find the maximum and minimum coordinates. + do j = l1, l2 { + + if (j == l1 || j == l2) { + + call amovkr (yref[j], Memr[y], ncols) + call gsvector (sx1, xref[c1], Memr[y], Memr[xin], ncols) + if (sx2 != NULL) { + call gsvector (sx2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[xin], Memr[temp], Memr[xin], ncols) + } + call gsvector (sy1, xref[c1], Memr[y], Memr[yin], ncols) + if (sy2 != NULL) { + call gsvector (sy2, xref[c1], Memr[y], Memr[temp], ncols) + call aaddr (Memr[yin], Memr[temp], Memr[yin], ncols) + } + + call alimr (Memr[xin], ncols, mintemp, maxtemp) + xmin = min (xmin, mintemp) + xmax = max (xmax, maxtemp) + call alimr (Memr[yin], ncols, mintemp, maxtemp) + ymin = min (ymin, mintemp) + ymax = max (ymax, maxtemp) + + } else { + + x1 = gseval (sx1, xref[c1], yref[j]) + x2 = gseval (sx1, xref[c1+ncols-1], yref[j]) + if (sx2 != NULL) { + x1 = x1 + gseval (sx2, xref[c1], yref[j]) + x2 = x2 + gseval (sx2, xref[c1+ncols-1], yref[j]) + } + xmin = min (xmin, x1, x2) + xmax = max (xmax, x1, x2) + + y1 = gseval (sy1, xref[c1], yref[j]) + y2 = gseval (sy1, xref[c1+ncols-1], yref[j]) + if (sy2 != NULL) { + y1 = y1 + gseval (sy2, xref[c1], yref[j]) + y2 = y2 + gseval (sy2, xref[c1+ncols-1], yref[j]) + } + ymin = min (ymin, y1, y2) + ymax = max (ymax, y1, y2) + + } + } + + call sfree (sp) +end + + +# GEO_MARGSET -- Set up interpolation margin + +procedure geo_margset (sx1, sy1, sx2, sy2, xmin, xmax, ncols, ymin, ymax, + nlines, interpolant, nsinc, nxymargin) + +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xmin, xmax #I the reference coordinate x limits +int ncols #I the number of output image columns +real ymin, ymax #I the reference coordinate y limits +int nlines #I the number of output image lines +int interpolant #I the interpolant type +int nsinc #I the sinc width +int nxymargin #O the interpolation margin + +int dist1, dist2, dist3, dist4, dist5, dist6 +pointer newsx, newsy +real x1, y1, x2, y2 +real gseval() + +begin + if (interpolant == II_SPLINE3 || interpolant == II_BISPLINE3) { + nxymargin = NMARGIN_SPLINE3 + } else if (interpolant == II_LSINC || interpolant == II_BILSINC) { + nxymargin = nsinc + } else if (interpolant == II_SINC || interpolant == II_BISINC) { + nxymargin = nsinc + } else if (interpolant == II_DRIZZLE || interpolant == II_BIDRIZZLE) { + if (sx2 == NULL) + call gscopy (sx1, newsx) + else + call gsadd (sx1, sx2, newsx) + if (sy2 == NULL) + call gscopy (sy1, newsy) + else + call gsadd (sy1, sy2, newsy) + x1 = gseval (newsx, xmin, ymin) + y1 = gseval (newsy, xmin, ymin) + x2 = gseval (newsx, xmax, ymin) + y2 = gseval (newsy, xmax, ymin) + dist1 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, xmax, ymax) + y1 = gseval (newsy, xmax, ymax) + dist2 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + x2 = gseval (newsx, xmin, ymax) + y2 = gseval (newsy, xmin, ymax) + dist3 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, xmin, ymin) + y1 = gseval (newsy, xmin, ymin) + dist4 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + x1 = gseval (newsx, xmin, (ymin + ymax) / 2.0) + y1 = gseval (newsy, xmin, (ymin + ymax) / 2.0) + x2 = gseval (newsx, xmax, (ymin + ymax) / 2.0) + y2 = gseval (newsy, xmax, (ymin + ymax) / 2.0) + dist5 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / ncols + x1 = gseval (newsx, (xmin + xmax) / 2.0, ymin) + y1 = gseval (newsy, (xmin + xmax) / 2.0, ymin) + x2 = gseval (newsx, (xmin + xmax) / 2.0, ymax) + y2 = gseval (newsy, (xmin + xmax) / 2.0, ymax) + dist6 = sqrt ((x1 - x2) ** 2 + (y1 - y2) ** 2) / nlines + nxymargin = max (NMARGIN, dist1, dist2, dist3, dist4, + dist5, dist6) + call gsfree (newsx) + call gsfree (newsy) + } else { + nxymargin = NMARGIN + } +end + + +# GEO_IMSET -- Set up input image boundary conditions. + +procedure geo_imset (im, geo, sx1, sy1, sx2, sy2, xref, nx, yref, ny) + +pointer im #I pointer to image +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors +real xref[ARB] #I x reference coordinates +int nx #I number of x reference coordinates +real yref[ARB] #I y reference coordinates +int ny #I number of y reference coordinates + +int bndry, npts +pointer sp, x1, x2, y1, y2, xtemp, ytemp +real xn1, xn2, xn3, xn4, yn1, yn2, yn3, yn4, xmin, xmax, ymin, ymax +real gseval() + +begin + npts = max (nx, ny) + + xn1 = gseval (sx1, GT_XMIN(geo), GT_YMIN(geo)) + xn2 = gseval (sx1, GT_XMAX(geo), GT_YMIN(geo)) + xn3 = gseval (sx1, GT_XMAX(geo), GT_YMAX(geo)) + xn4 = gseval (sx1, GT_XMIN(geo), GT_YMAX(geo)) + + yn1 = gseval (sy1, GT_XMIN(geo), GT_YMIN(geo)) + yn2 = gseval (sy1, GT_XMAX(geo), GT_YMIN(geo)) + yn3 = gseval (sy1, GT_XMAX(geo), GT_YMAX(geo)) + yn4 = gseval (sy1, GT_XMIN(geo), GT_YMAX(geo)) + + xmin = min (xn1, xn2, xn3, xn4) + ymin = min (yn1, yn2, yn3, yn4) + xmax = max (xn1, xn2, xn3, xn4) + ymax = max (yn1, yn2, yn3, yn4) + + if (sx2 != NULL) { + call smark (sp) + call salloc (x1, npts, TY_REAL) + call salloc (x2, npts, TY_REAL) + call salloc (xtemp, npts, TY_REAL) + call salloc (ytemp, npts, TY_REAL) + + call amovkr (GT_YMIN(geo), Memr[ytemp], nx) + call gsvector (sx1, xref, Memr[ytemp], Memr[x1], nx) + call gsvector (sx2, xref, Memr[ytemp], Memr[x2], nx) + call aaddr (Memr[x1], Memr[x2], Memr[x1], nx) + call alimr (Memr[x1], nx, xn1, yn1) + + call amovkr (GT_XMAX(geo), Memr[xtemp], ny) + call gsvector (sx1, Memr[xtemp], yref, Memr[x1], ny) + call gsvector (sx2, Memr[xtemp], yref, Memr[x2], ny) + call aaddr (Memr[x1], Memr[x2], Memr[x1], ny) + call alimr (Memr[x1], ny, xn2, yn2) + + call amovkr (GT_YMAX(geo), Memr[ytemp], nx) + call gsvector (sx1, xref, Memr[ytemp], Memr[x1], nx) + call gsvector (sx2, xref, Memr[ytemp], Memr[x2], nx) + call aaddr (Memr[x1], Memr[x2], Memr[x1], nx) + call alimr (Memr[x1], nx, xn3, yn3) + + call amovkr (GT_XMIN(geo), Memr[xtemp], ny) + call gsvector (sx1, Memr[xtemp], yref, Memr[x1], ny) + call gsvector (sx2, Memr[xtemp], yref, Memr[x2], ny) + call aaddr (Memr[x1], Memr[x2], Memr[x1], ny) + call alimr (Memr[x1], ny, xn4, yn4) + + xmin = min (xn1, xn2, xn3, xn4) + xmax = max (yn1, yn2, yn3, yn4) + + call sfree (sp) + } + + if (sy2 != NULL) { + call smark (sp) + call salloc (y1, npts, TY_REAL) + call salloc (y2, npts, TY_REAL) + call salloc (xtemp, npts, TY_REAL) + call salloc (ytemp, npts, TY_REAL) + + call amovkr (GT_YMIN(geo), Memr[ytemp], nx) + call gsvector (sy1, xref, Memr[ytemp], Memr[y1], nx) + call gsvector (sy2, xref, Memr[ytemp], Memr[y2], nx) + call aaddr (Memr[y1], Memr[y2], Memr[y1], nx) + call alimr (Memr[y1], nx, xn1, yn1) + + call amovkr (GT_XMAX(geo), Memr[xtemp], ny) + call gsvector (sy1, Memr[xtemp], yref, Memr[y1], ny) + call gsvector (sy2, Memr[xtemp], yref, Memr[y2], ny) + call aaddr (Memr[y1], Memr[y2], Memr[y1], ny) + call alimr (Memr[y1], ny, xn2, yn2) + + call amovkr (GT_YMAX(geo), Memr[ytemp], nx) + call gsvector (sy1, xref, Memr[ytemp], Memr[y1], nx) + call gsvector (sy2, xref, Memr[ytemp], Memr[y2], nx) + call aaddr (Memr[y1], Memr[y2], Memr[y1], nx) + call alimr (Memr[y1], nx, xn3, yn3) + + call amovkr (GT_XMIN(geo), Memr[xtemp], ny) + call gsvector (sy1, Memr[xtemp], yref, Memr[y1], ny) + call gsvector (sy2, Memr[xtemp], yref, Memr[y2], ny) + call aaddr (Memr[y1], Memr[y2], Memr[y1], ny) + call alimr (Memr[y1], ny, xn4, yn4) + + ymin = min (xn1, xn2, xn3, xn4) + ymax = max (yn1, yn2, yn3, yn4) + + call sfree (sp) + } + + # Compute the out-of-bounds limit. + if (IM_NDIM(im) == 1) { + if (xmin < 1.0 || xmax > real (IM_LEN(im,1))) + bndry = max (1.0 - xmin, xmax - IM_LEN(im,1)) + 1 + else + bndry = 1 + } else { + if (xmin < 1.0 || ymin < 1.0 || xmax > real (IM_LEN(im,1)) || + ymax > real (IM_LEN(im,2))) + bndry = max (1.0 - xmin, 1.0 - ymin, xmax - IM_LEN(im,1), + ymax - IM_LEN(im,2)) + 1 + else + bndry = 1 + } + + call imseti (im, IM_NBNDRYPIX, bndry + GT_NXYMARGIN(geo) + 1) + call imseti (im, IM_TYBNDRY, GT_BOUNDARY(geo)) + call imsetr (im, IM_BNDRYPIXVAL, GT_CONSTANT(geo)) +end + + +# GEO_GSFLUX -- Preserve the image flux after a transformation. + +procedure geo_gsflux (xref, yref, buf, c1, c2, line, sx1, sy1, sx2, sy2) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real buf[ARB] #O output image buffer +int c1, c2 #I column limits in the output image +int line #I line in the output image +pointer sx1, sy1 #I linear surface descriptors +pointer sx2, sy2 #I distortion surface descriptors + +int ncols +pointer sp, y, der1, der2, jacob, sx, sy + +begin + ncols = c2 - c1 + 1 + + # Get the reference coordinates. + call smark (sp) + call salloc (y, ncols, TY_REAL) + call salloc (jacob, ncols, TY_REAL) + + # Add the two surfaces together for efficiency. + if (sx2 != NULL) + call gsadd (sx1, sx2, sx) + else + call gscopy (sx1, sx) + if (sy1 == NULL) + sy = NULL + else if (sy2 != NULL) + call gsadd (sy1, sy2, sy) + else + call gscopy (sy1, sy) + + # Multiply the output buffer by the Jacobian. + call amovkr (yref[line], Memr[y], ncols) + if (sy == NULL) + call gsder (sx, xref[c1], Memr[y], Memr[jacob], ncols, 1, 0) + else { + call salloc (der1, ncols, TY_REAL) + call salloc (der2, ncols, TY_REAL) + call gsder (sx, xref[c1], Memr[y], Memr[der1], ncols, 1, 0) + call gsder (sy, xref[c1], Memr[y], Memr[der2], ncols, 0, 1) + call amulr (Memr[der1], Memr[der2], Memr[jacob], ncols) + call gsder (sx, xref[c1], Memr[y], Memr[der1], ncols, 0, 1) + call gsder (sy, xref[c1], Memr[y], Memr[der2], ncols, 1, 0) + call amulr (Memr[der1], Memr[der2], Memr[der1], ncols) + call asubr (Memr[jacob], Memr[der1], Memr[jacob], ncols) + } + call aabsr (Memr[jacob], Memr[jacob], ncols) + call amulr (buf, Memr[jacob], buf, ncols) + + # Clean up. + call gsfree (sx) + if (sy != NULL) + call gsfree (sy) + call sfree (sp) +end + + +# GEO_MSIFLUX -- Procedure to interpolate the surface coordinates + +procedure geo_msiflux (jmsi, xinterp, yinterp, outdata, c1, c2, line, x0, y0) + +pointer jmsi #I pointer to the jacobian interpolant +real xinterp[ARB] #I x reference coordinates +real yinterp[ARB] #I y reference coordinates +real outdata[ARB] #O output data +int c1, c2 #I column limits in output image +int line #I line to be flux corrected +int x0, y0 #I zero points of interpolation coordinates + +int ncols +pointer sp, x, y, jacob + +begin + # Allocate tempoaray space. + call smark (sp) + ncols = c2 - c1 + 1 + call salloc (x, ncols, TY_REAL) + call salloc (jacob, ncols, TY_REAL) + + # Calculate the x points. + if (x0 == 1) + call amovr (xinterp[c1], Memr[x], ncols) + else + call aaddkr (xinterp[c1], real (-x0 + 1), Memr[x], ncols) + + # Multiply the data by the Jacobian. + if (line == 0) { + call asivector (jmsi, Memr[x], Memr[jacob], ncols) + } else { + call salloc (y, ncols, TY_REAL) + call amovkr ((yinterp[line] + real (-y0 + 1)), Memr[y], ncols) + call msivector (jmsi, Memr[x], Memr[y], Memr[jacob], ncols) + } + call aabsr (Memr[jacob], Memr[jacob], ncols) + call amulr (outdata, Memr[jacob], outdata, ncols) + + call sfree (sp) +end + + +# GEO_JFACTOR -- Compute the Jacobian of a linear transformation. + +real procedure geo_jfactor (sx1, sy1) + +pointer sx1 #I pointer to x surface +pointer sy1 #I pointer to y surface + +real xval, yval, xx, xy, yx, yy +real gsgetr() + +begin + xval = (gsgetr (sx1, GSXMIN) + gsgetr (sx1, GSXMAX)) / 2.0 + if (sy1 == NULL) + yval = 1.0 + else + yval = (gsgetr (sy1, GSYMIN) + gsgetr (sy1, GSYMIN)) / 2.0 + + call gsder (sx1, xval, yval, xx, 1, 1, 0) + if (sy1 == NULL) { + xy = 0.0 + yy = 1.0 + yx = 0.0 + } else { + call gsder (sx1, xval, yval, xy, 1, 0, 1) + call gsder (sy1, xval, yval, yx, 1, 1, 0) + call gsder (sy1, xval, yval, yy, 1, 0, 1) + } + + return (abs (xx * yy - xy * yx)) +end + + +# GEO_REPEAT -- Copy a small repeated pattern into the output buffer. + +procedure geo_repeat (pat, npat, output, ntimes) + +real pat[ARB] #I the input pattern to be repeated +int npat #I the size of the pattern +real output[ARB] #O the output array +int ntimes #I the number of times the pattern is to be repeated + +int j, i, offset + +begin + do j = 1, ntimes { + offset = npat * j - npat + do i = 1, npat + output[offset+i] = pat[i] + } +end diff --git a/pkg/images/immatch/src/geometry/geoxytran.gx b/pkg/images/immatch/src/geometry/geoxytran.gx new file mode 100644 index 00000000..22d577f1 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geoxytran.gx @@ -0,0 +1,327 @@ +include +include +include +include + +define GEO_LINEAR 1 # Linear transformation only +define GEO_DISTORTION 2 # Distortion correction only +define GEO_GEOMETRIC 3 # Full transformation + +$for (rd) + +# GEO_LINIT -- Initialize the linear part of the transformation. + +$if (datatype == r) +procedure geo_linitr (sx1, sy1, sx2, sy2) +$else +procedure geo_linitd (sx1, sy1, sx2, sy2) +$endif + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +PIXEL xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +$if (datatype == r) +real clgetr(), gseval() +$else +double clgetd(), dgseval() +$endif + +begin + # Initialize the surfaces. +$if (datatype == r) + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) +$else + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) +$endif + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clget$t ("xmag") + if (IS_$INDEF$T(xmag)) + xmag = PIXEL(1.0) + ymag = clget$t ("ymag") + if (IS_$INDEF$T(ymag)) + ymag = PIXEL(1.0) + + # Get the rotation parameters. + xrot = clget$t ("xrot") + if (IS_$INDEF$T(xrot)) + xrot = PIXEL(0.0) + xrot = -DEGTORAD(xrot) + yrot = clget$t ("yrot") + if (IS_$INDEF$T(yrot)) + yrot = PIXEL(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmag$t (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clget$t ("xref") + if (IS_$INDEF$T(xref)) + xref = PIXEL(0.0) + yref = clget$t ("yref") + if (IS_$INDEF$T(yref)) + yref = PIXEL(0.0) + + # Compute the corresponding input coordinates. + xout = clget$t ("xout") + if (IS_$INDEF$T(xout)) +$if (datatype == r) + xout = gseval (sx1, xref, yref) +$else + xout = dgseval (sx1, xref, yref) +$endif + yout = clget$t ("yout") + if (IS_$INDEF$T(yout)) +$if (datatype == r) + yout = gseval (sy1, xref, yref) +$else + yout = dgseval (sy1, xref, yref) +$endif + + # Set the shifts. + xshift = clget$t ("xshift") + yshift = clget$t ("yshift") +$if (datatype == r) + if (IS_$INDEF$T(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - gseval (sy1, xref, yref) +$else + if (IS_$INDEF$T(xshift)) + xshift = xout - $tgseval (sx1, xref, yref) + if (IS_$INDEF$T(yshift)) + yshift = yout - $tgseval (sy1, xref, yref) +$endif + call geo_xyshift$t (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +$if (datatype == r) +procedure geo_sfreer (sx1, sy1, sx2, sy2) +$else +procedure geo_sfreed (sx1, sy1, sx2, sy2) +$endif + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin +$if (datatype == r) + call gsfree (sx1) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +$else + call dgsfree (sx1) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +$endif +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinit$t (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +PIXEL xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +PIXEL clget$t() +$if (datatype == r) +errchk gsrestore +$else +errchk dgsrestore +$endif + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_PIXEL) + call malloc (ycoeff, ncoeff, TY_PIXEL) + do i = 1, ncoeff { + junk = dtscan (dt) + call garg$t (Mem$t[xcoeff+i-1]) + call garg$t (Mem$t[ycoeff+i-1]) + } + + # Restore linear part of fit. +$if (datatype == r) + call gsrestore (sx1, Mem$t[xcoeff]) + call gsrestore (sy1, Mem$t[ycoeff]) +$else + call dgsrestore (sx1, Mem$t[xcoeff]) + call dgsrestore (sy1, Mem$t[ycoeff]) +$endif + + # Get geometric transformation. + xmag = clget$t ("xmag") + ymag = clget$t ("ymag") + xrot = clget$t ("xrotation") + yrot = clget$t ("yrotation") + xout = clget$t ("xout") + yout = clget$t ("yout") + xref = clget$t ("xref") + yref = clget$t ("yref") + xshift = clget$t ("xshift") + yshift = clget$t ("yshift") + + # Get set to adjust linear part of the fit. +$if (datatype == r) + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) +$else + call dgscopy (sx1, newsx1) + call dgscopy (sy1, newsy1) +$endif + + if (geometry == GEO_DISTORTION) + call geo_rotmag$t (newsx1, newsy1, PIXEL(1.0), PIXEL(1.0), + PIXEL(0.0), PIXEL(0.0)) + else if (! IS_$INDEF$T(xmag) || ! IS_$INDEF$T(ymag) || + ! IS_$INDEF$T(xrot) || ! IS_$INDEF$T(yrot)) + call geo_drotmag$t (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshift$t (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) +$if (datatype == r) + call gssave (newsx1, Mem$t[xcoeff]) + call gssave (newsy1, Mem$t[ycoeff]) +$else + call dgssave (newsx1, Mem$t[xcoeff]) + call dgssave (newsy1, Mem$t[ycoeff]) +$endif + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_PIXEL) + call realloc (ycoeff, ncoeff, TY_PIXEL) + do i = 1, ncoeff { + junk = dtscan (dt) + call garg$t (Mem$t[xcoeff+i-1]) + call garg$t (Mem$t[ycoeff+i-1]) + } + + # Restore distortion part of fit. +$if (datatype == r) + iferr { + call gsrestore (sx2, Mem$t[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Mem$t[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } +$else + iferr { + call dgsrestore (sx2, Mem$t[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Mem$t[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } +$endif + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. +$if (datatype == r) + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) +$else + call dgsfree (sx1) + call dgscopy (newsx1, sx1) + call dgsfree (newsx1) + call dgsfree (sy1) + call dgscopy (newsy1, sy1) + call dgsfree (newsy1) +$endif + + # Cleanup. + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transform$t (x, y, xt, yt, sx1, sy1, sx2, sy2) + +PIXEL x, y # initial positions +PIXEL xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +$if (datatype == r) +real gseval() +$else +double dgseval() +$endif + +begin +$if (datatype == r) + xt = gseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + gseval (sx2, x, y) + yt = gseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + gseval (sy2, x, y) +$else + xt = dgseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + dgseval (sx2, x, y) + yt = dgseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + dgseval (sy2, x, y) +$endif +end + +$endfor diff --git a/pkg/images/immatch/src/geometry/geoxytran.x b/pkg/images/immatch/src/geometry/geoxytran.x new file mode 100644 index 00000000..e8bb9f64 --- /dev/null +++ b/pkg/images/immatch/src/geometry/geoxytran.x @@ -0,0 +1,446 @@ +include +include +include +include + +define GEO_LINEAR 1 # Linear transformation only +define GEO_DISTORTION 2 # Distortion correction only +define GEO_GEOMETRIC 3 # Full transformation + + + +# GEO_LINIT -- Initialize the linear part of the transformation. + +procedure geo_linitr (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +real xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +real clgetr(), gseval() + +begin + # Initialize the surfaces. + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, -MAX_REAL, MAX_REAL, + -MAX_REAL, MAX_REAL) + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clgetr ("xmag") + if (IS_INDEFR(xmag)) + xmag = real(1.0) + ymag = clgetr ("ymag") + if (IS_INDEFR(ymag)) + ymag = real(1.0) + + # Get the rotation parameters. + xrot = clgetr ("xrot") + if (IS_INDEFR(xrot)) + xrot = real(0.0) + xrot = -DEGTORAD(xrot) + yrot = clgetr ("yrot") + if (IS_INDEFR(yrot)) + yrot = real(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmagr (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clgetr ("xref") + if (IS_INDEFR(xref)) + xref = real(0.0) + yref = clgetr ("yref") + if (IS_INDEFR(yref)) + yref = real(0.0) + + # Compute the corresponding input coordinates. + xout = clgetr ("xout") + if (IS_INDEFR(xout)) + xout = gseval (sx1, xref, yref) + yout = clgetr ("yout") + if (IS_INDEFR(yout)) + yout = gseval (sy1, xref, yref) + + # Set the shifts. + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + if (IS_INDEFR(xshift)) + xshift = xout - gseval (sx1, xref, yref) + if (IS_INDEFR(yshift)) + yshift = yout - gseval (sy1, xref, yref) + call geo_xyshiftr (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +procedure geo_sfreer (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin + call gsfree (sx1) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinitr (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +real xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +real clgetr() +errchk gsrestore + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_REAL) + call malloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + + # Restore linear part of fit. + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + # Get geometric transformation. + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + xrot = clgetr ("xrotation") + yrot = clgetr ("yrotation") + xout = clgetr ("xout") + yout = clgetr ("yout") + xref = clgetr ("xref") + yref = clgetr ("yref") + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + + # Get set to adjust linear part of the fit. + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) + + if (geometry == GEO_DISTORTION) + call geo_rotmagr (newsx1, newsy1, real(1.0), real(1.0), + real(0.0), real(0.0)) + else if (! IS_INDEFR(xmag) || ! IS_INDEFR(ymag) || + ! IS_INDEFR(xrot) || ! IS_INDEFR(yrot)) + call geo_drotmagr (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshiftr (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) + call gssave (newsx1, Memr[xcoeff]) + call gssave (newsy1, Memr[ycoeff]) + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_REAL) + call realloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + + # Restore distortion part of fit. + iferr { + call gsrestore (sx2, Memr[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Memr[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transformr (x, y, xt, yt, sx1, sy1, sx2, sy2) + +real x, y # initial positions +real xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +real gseval() + +begin + xt = gseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + gseval (sx2, x, y) + yt = gseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + gseval (sy2, x, y) +end + + + +# GEO_LINIT -- Initialize the linear part of the transformation. + +procedure geo_linitd (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +double xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +double clgetd(), dgseval() + +begin + # Initialize the surfaces. + call dgsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + call dgsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, double (-MAX_REAL), + double (MAX_REAL), double (-MAX_REAL), double (MAX_REAL)) + sx2 = NULL + sy2 = NULL + + # Get the magnification parameters. + xmag = clgetd ("xmag") + if (IS_INDEFD(xmag)) + xmag = double(1.0) + ymag = clgetd ("ymag") + if (IS_INDEFD(ymag)) + ymag = double(1.0) + + # Get the rotation parameters. + xrot = clgetd ("xrot") + if (IS_INDEFD(xrot)) + xrot = double(0.0) + xrot = -DEGTORAD(xrot) + yrot = clgetd ("yrot") + if (IS_INDEFD(yrot)) + yrot = double(0.0) + yrot = -DEGTORAD(yrot) + + # Set the magnification and rotation coefficients. + call geo_rotmagd (sx1, sy1, xmag, ymag, xrot, yrot) + + # Compute the origin of the reference coordinates. + xref = clgetd ("xref") + if (IS_INDEFD(xref)) + xref = double(0.0) + yref = clgetd ("yref") + if (IS_INDEFD(yref)) + yref = double(0.0) + + # Compute the corresponding input coordinates. + xout = clgetd ("xout") + if (IS_INDEFD(xout)) + xout = dgseval (sx1, xref, yref) + yout = clgetd ("yout") + if (IS_INDEFD(yout)) + yout = dgseval (sy1, xref, yref) + + # Set the shifts. + xshift = clgetd ("xshift") + yshift = clgetd ("yshift") + if (IS_INDEFD(xshift)) + xshift = xout - dgseval (sx1, xref, yref) + if (IS_INDEFD(yshift)) + yshift = yout - dgseval (sy1, xref, yref) + call geo_xyshiftd (sx1, sy1, xshift, yshift) +end + + +# GEO_SFREE -- Free the x and y surface fitting descriptors. + +procedure geo_sfreed (sx1, sy1, sx2, sy2) + +pointer sx1, sy1 #I/O pointers to the linear x and y surfaces +pointer sx2, sy2 #I/O pointer to the distortion x and y surfaces + +begin + call dgsfree (sx1) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +end + + +# GEO_SINIT -- Read the surface fits from the database file and make +# any requested changes. + +procedure geo_sinitd (dt, record, geometry, sx1, sy1, sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +int i, rec, ncoeff, junk +double xmag, ymag, xrot, yrot, xref, yref, xout, yout, xshift, yshift +pointer newsx1, newsy1, xcoeff, ycoeff +int dtlocate(), dtscan(), dtgeti() +double clgetd() +errchk dgsrestore + +begin + # Locate record. + rec = dtlocate (dt, record) + + # Get linear part of fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_DOUBLE) + call malloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore linear part of fit. + call dgsrestore (sx1, Memd[xcoeff]) + call dgsrestore (sy1, Memd[ycoeff]) + + # Get geometric transformation. + xmag = clgetd ("xmag") + ymag = clgetd ("ymag") + xrot = clgetd ("xrotation") + yrot = clgetd ("yrotation") + xout = clgetd ("xout") + yout = clgetd ("yout") + xref = clgetd ("xref") + yref = clgetd ("yref") + xshift = clgetd ("xshift") + yshift = clgetd ("yshift") + + # Get set to adjust linear part of the fit. + call dgscopy (sx1, newsx1) + call dgscopy (sy1, newsy1) + + if (geometry == GEO_DISTORTION) + call geo_rotmagd (newsx1, newsy1, double(1.0), double(1.0), + double(0.0), double(0.0)) + else if (! IS_INDEFD(xmag) || ! IS_INDEFD(ymag) || + ! IS_INDEFD(xrot) || ! IS_INDEFD(yrot)) + call geo_drotmagd (dt, rec, newsx1, newsy1, xmag, ymag, + xrot, yrot) + call geo_dxyshiftd (dt, rec, newsx1, newsy1, xout, yout, xref, yref, + xshift, yshift) + call dgssave (newsx1, Memd[xcoeff]) + call dgssave (newsy1, Memd[ycoeff]) + + # Get distortion part of fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (geometry == GEO_GEOMETRIC || + geometry == GEO_DISTORTION)) { + + call realloc (xcoeff, ncoeff, TY_DOUBLE) + call realloc (ycoeff, ncoeff, TY_DOUBLE) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargd (Memd[xcoeff+i-1]) + call gargd (Memd[ycoeff+i-1]) + } + + # Restore distortion part of fit. + iferr { + call dgsrestore (sx2, Memd[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call dgsrestore (sy2, Memd[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + sx2 = NULL + sy2 = NULL + } + + # Redefine the linear surfaces. + call dgsfree (sx1) + call dgscopy (newsx1, sx1) + call dgsfree (newsx1) + call dgsfree (sy1) + call dgscopy (newsy1, sy1) + call dgsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) +end + + +# GEO_DO_TRANSFORM -- The linear transformation is performed in this procedure. +# First the coordinates are scaled, then rotated and translated. The +# transformed coordinates are returned. + +procedure geo_do_transformd (x, y, xt, yt, sx1, sy1, sx2, sy2) + +double x, y # initial positions +double xt, yt # transformed positions +pointer sx1, sy1 # pointer to linear surfaces +pointer sx2, sy2 # pointer to distortion surfaces + +double dgseval() + +begin + xt = dgseval (sx1, x, y) + if (sx2 != NULL) + xt = xt + dgseval (sx2, x, y) + yt = dgseval (sy1, x, y) + if (sy2 != NULL) + yt = yt + dgseval (sy2, x, y) +end + + diff --git a/pkg/images/immatch/src/geometry/mkpkg b/pkg/images/immatch/src/geometry/mkpkg new file mode 100644 index 00000000..e6e98b24 --- /dev/null +++ b/pkg/images/immatch/src/geometry/mkpkg @@ -0,0 +1,34 @@ +# Make the GEOMAP/GEOXYTRAN and CCMAP/CCSETWCS/CCTRAN tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (geofunc.x, geofunc.gx) + $(GEN) geofunc.gx -o geofunc.x $endif + $ifolder (t_geomap.x, t_geomap.gx) + $(GEN) t_geomap.gx -o t_geomap.x $endif + $ifolder (geoxytran.x,geoxytran.gx) + $(GEN) geoxytran.gx -o geoxytran.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + geofunc.x + geotimtran.x \ + geotran.h + geotran.x \ + geotran.h + geoxytran.x + t_geomap.x \ + "../../../lib/geomap.h" + t_geotran.x \ + geotran.h + t_geoxytran.x + trinvert.x + ; diff --git a/pkg/images/immatch/src/geometry/t_geomap.gx b/pkg/images/immatch/src/geometry/t_geomap.gx new file mode 100644 index 00000000..02d530e5 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geomap.gx @@ -0,0 +1,921 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "../../../lib/geomap.h" + +define GM_REAL 1 # computation type is real +define GM_DOUBLE 2 # computation type is double + +$for (r) + +# T_GEOMAP -- Procedure to calculate the transformation required to transform +# the coordinate system of a reference image to the coordinate system of +# an input image. The transformation is of the following form. +# +# xin = f (xref, yref) +# yin = g (xref, yref) + +procedure t_geomap () + +bool verbose, interactive +double xmin, xmax, ymin, ymax, reject +int geometry, function, calctype, nfiles, list, in, reclist, nrecords +int xxorder, xyorder, xxterms, yxorder, yyorder, yxterms, maxiter +int reslist, nresfiles, res +pointer sp, in_name, str, out, fit, gd, graphics +real rxmin, rxmax, rymin, rymax + +bool clgetb() +double clgetd() +int clgeti(), clgwrd(), clplen(), errget(), imtopenp(), imtlen() +int imtgetim() +pointer clpopnu(), clgfil(), dtmap(), gopen(), open() + +errchk geo_mapr(), geo_mapd() + +begin + # Get working space. + call smark (sp) + call salloc (in_name, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (str, max(SZ_LINE, SZ_FNAME), TY_CHAR) + + # Get input data file(s). + list = clpopnu ("input") + nfiles = clplen (list) + + # Open database output file. + call clgstr ("database", Memc[str], SZ_FNAME) + out = dtmap (Memc[str], APPEND) + + # Get minimum and maximum reference values. + xmin = clgetd ("xmin") + if (IS_INDEFD(xmin)) + rxmin = INDEFR + else + rxmin = xmin + xmax = clgetd ("xmax") + if (IS_INDEFD(xmax)) + rxmax = INDEFR + else + rxmax = xmax + ymin = clgetd ("ymin") + if (IS_INDEFD(ymin)) + rymin = INDEFR + else + rymin = ymin + ymax = clgetd ("ymax") + if (IS_INDEFD(ymax)) + rymax = INDEFR + else + rymax = ymax + + # Get the records list. + reclist = imtopenp ("transforms") + nrecords = imtlen (reclist) + if ((nrecords > 0) && (nrecords != nfiles)) { + call eprintf ( + "The number of records is not equal to the number of input files") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the results file list. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != nfiles) { + call eprintf ("Error: there are too few results files\n") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call clpcls (reslist) + call sfree (sp) + return + } + + # Get the surface fitting parameters. + geometry = clgwrd ("fitgeometry", Memc[str], SZ_LINE, GM_GEOMETRIES) + function = clgwrd ("function", Memc[str], SZ_LINE, GM_FUNCS) + xxorder = clgeti ("xxorder") + xyorder = clgeti ("xyorder") + xxterms = clgwrd ("xxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + yxorder = clgeti ("yxorder") + yyorder = clgeti ("yyorder") + yxterms = clgwrd ("yxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + maxiter = clgeti ("maxiter") + reject = clgetd ("reject") + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, ",real,double,") + + # Get the graphics parameters. + verbose = clgetb ("verbose") + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the fit structure. + call geo_minit (fit, GM_NONE, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + + # Loop over the files. + while (clgfil (list, Memc[in_name], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[in_name], READ_ONLY, TEXT_FILE) + + # Open the results files. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Set file name in structure. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else + call strcpy (Memc[in_name], GM_RECORD(fit), SZ_FNAME) + + if (verbose && res != STDOUT) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("\nCoordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call printf (" Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + if (res != NULL) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call fprintf (res, "\n# Coordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call fprintf (res, "# Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + + if (interactive) { + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + } else + gd = NULL + + iferr { + if (calctype == GM_REAL) + call geo_mapr (gd, in, out, res, fit, rxmin, rxmax, rymin, + rymax, verbose) + else + call geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, + ymax, verbose) + } then { + if (verbose && res != STDOUT) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf ("\t%s\n") + call pargstr (Memc[str)) + } + if (res != NULL) { + call fprintf (res, "# Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str)) + } + } + + call close (in) + if (nresfiles == nfiles) + call close ( res) + + if (gd != NULL) + call gclose (gd) + } + + # Close up. + call geo_free (fit) + if (nresfiles < nfiles) + call close ( res) + call dtunmap (out) + call imtclose (reclist) + call clpcls (list) + call sfree (sp) +end + +$endfor + +$for (rd) + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_map$t (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +PIXEL xmin, xmax #I max and min xref values +PIXEL ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +PIXEL mintemp, maxtemp + +PIXEL asum$t() +int geo_rdxy$t() +errchk geo_fit$t, geo_mgfit$t() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxy$t (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asum$t (Mem$t[xref], npts) / npts) + GM_YOREF(fit) = double (asum$t (Mem$t[yref], npts) / npts) + GM_XOIN(fit) = double (asum$t (Mem$t[xin], npts) / npts) + GM_YOIN(fit) = double (asum$t (Mem$t[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_PIXEL) + call malloc (yfit, npts, TY_PIXEL) + call malloc (wts, npts, TY_PIXEL) + call amovk$t (PIXEL(1.), Mem$t[wts], npts) + + # Determine the x max and min. + if (IS_$INDEF$T(xmin) || IS_$INDEF$T(xmax)) { + call alim$t (Mem$t[xref], npts, mintemp, maxtemp) + if (! IS_$INDEF$T(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_$INDEF$T(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_$INDEF$T(ymin) || IS_$INDEF$T(ymax)) { + call alim$t (Mem$t[yref], npts, mintemp, maxtemp) + if (! IS_$INDEF$T(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_$INDEF$T(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfit$t (gd, fit, sx1, sy1, sx2, sy2, Mem$t[xref], + Mem$t[yref], Mem$t[xin], Mem$t[yin], Mem$t[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_PIXEL) + call mfree (yfit, TY_PIXEL) + call mfree (wts, TY_PIXEL) + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fit$t (fit, sx1, sy1, sx2, sy2, Mem$t[xref], + Mem$t[yref], Mem$t[xin], Mem$t[yin], Mem$t[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_PIXEL) + call mfree (yfit, TY_PIXEL) + call mfree (wts, TY_PIXEL) + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_show$t (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_show$t (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_eval$t (sx1, sy1, sx2, sy2, Mem$t[xref], Mem$t[yref], + Mem$t[xfit], Mem$t[yfit], npts) + call geo_plist$t (res, fit, Mem$t[xref], Mem$t[yref], Mem$t[xin], + Mem$t[yin], Mem$t[xfit], Mem$t[yfit], Mem$t[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_PIXEL) + if (yref != NULL) + call mfree (yref, TY_PIXEL) + if (xin != NULL) + call mfree (xin, TY_PIXEL) + if (yin != NULL) + call mfree (yin, TY_PIXEL) + if (xfit != NULL) + call mfree (xfit, TY_PIXEL) + if (yfit != NULL) + call mfree (yfit, TY_PIXEL) + if (wts != NULL) + call mfree (wts, TY_PIXEL) + + # Output the data. + call geo_mout$t (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfree$t (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxy$t (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +PIXEL xmin, xmax # the range of the x coordinates +PIXEL ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_PIXEL) + call malloc (yref, bufsize, TY_PIXEL) + call malloc (xin, bufsize, TY_PIXEL) + call malloc (yin, bufsize, TY_PIXEL) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call garg$t (Mem$t[xref+npts]) + call garg$t (Mem$t[yref+npts]) + call garg$t (Mem$t[xin+npts]) + call garg$t (Mem$t[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_$INDEF$T(xmin)) { + if (Mem$t[xref+npts] < xmin) + next + } + if (! IS_$INDEF$T(xmax)) { + if (Mem$t[xref+npts] > xmax) + next + } + if (! IS_$INDEF$T(ymin)) { + if (Mem$t[yref+npts] < ymin) + next + } + if (! IS_$INDEF$T(ymax)) { + if (Mem$t[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_PIXEL) + call realloc (yref, bufsize, TY_PIXEL) + call realloc (xin, bufsize, TY_PIXEL) + call realloc (yin, bufsize, TY_PIXEL) + } + } + + if (npts <= 0) { + call mfree (xref, TY_PIXEL) + call mfree (yref, TY_PIXEL) + call mfree (xin, TY_PIXEL) + call mfree (yin, TY_PIXEL) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_PIXEL) + call realloc (yref, npts, TY_PIXEL) + call realloc (xin, npts, TY_PIXEL) + call realloc (yin, npts, TY_PIXEL) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_eval$t (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +PIXEL xref[ARB] #I the x reference coordinates +PIXEL yref[ARB] #I the y reference coordinates +PIXEL xi[ARB] #O the fitted xi coordinates +PIXEL eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_PIXEL) + +$if (datatype == r) + call gsvector (sx1, xref, yref, xi, npts) +$else + call dgsvector (sx1, xref, yref, xi, npts) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, xref, yref, Mem$t[temp], npts) +$else + call dgsvector (sx2, xref, yref, Mem$t[temp], npts) +$endif + call aadd$t (Mem$t[temp], xi, xi, npts) + } +$if (datatype == r) + call gsvector (sy1, xref, yref, eta, npts) +$else + call dgsvector (sy1, xref, yref, eta, npts) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, xref, yref, Mem$t[temp], npts) +$else + call dgsvector (sy2, xref, yref, Mem$t[temp], npts) +$endif + + call aadd$t (Mem$t[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_mout$t (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +PIXEL xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeff$t (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call parg$t (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call parg$t (yshift) + call dtput (out, "\txmag\t\t%g\n") + call parg$t (xscale) + call dtput (out, "\tymag\t\t%g\n") + call parg$t (yscale) + call dtput (out, "\txrotation\t%g\n") + call parg$t (xrot) + call dtput (out, "\tyrotation\t%g\n") + call parg$t (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call parg$t (PIXEL(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call parg$t (PIXEL(yrms)) + + # Allocate memory for linear coefficients. +$if (datatype == r) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) +$else + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) +$endif + call calloc (xcoeff, ncoeff, TY_PIXEL) + call calloc (ycoeff, ncoeff, TY_PIXEL) + + # Output the linear coefficients. +$if (datatype == r) + call gssave (sx1, Mem$t[xcoeff]) + call gssave (sy1, Mem$t[ycoeff]) +$else + call dgssave (sx1, Mem$t[xcoeff]) + call dgssave (sy1, Mem$t[ycoeff]) +$endif + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call parg$t (Mem$t[xcoeff+i-1]) + call parg$t (Mem$t[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else +$if (datatype == r) + ncoeff = gsgeti (sx2, GSNSAVE) +$else + ncoeff = dgsgeti (sx2, GSNSAVE) +$endif + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else +$if (datatype == r) + ncoeff = max (gsgeti (sy2, GSNSAVE), ncoeff) +$else + ncoeff = max (dgsgeti (sy2, GSNSAVE), ncoeff) +$endif + call calloc (xcoeff, ncoeff, TY_PIXEL) + call calloc (ycoeff, ncoeff, TY_PIXEL) + + # Save the coefficients. +$if (datatype == r) + call gssave (sx2, Mem$t[xcoeff]) + call gssave (sy2, Mem$t[ycoeff]) +$else + call dgssave (sx2, Mem$t[xcoeff]) + call dgssave (sy2, Mem$t[ycoeff]) +$endif + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call parg$t (Mem$t[xcoeff+i-1]) + call parg$t (Mem$t[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_PIXEL) + call mfree (ycoeff, TY_PIXEL) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plist$t (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +PIXEL xref[ARB] #I the input x coordinates +PIXEL yref[ARB] #I the input y coordinates +PIXEL xin[ARB] #I the input ra / longitude coordinates +PIXEL yin[ARB] #I the input dec / latitude coordinates +PIXEL xfit[ARB] #I the fitted ra / longitude coordinates +PIXEL yfit[ARB] #I the fitted dec / latitude coordinates +PIXEL wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_PIXEL) + + # Compute the weights. + call amov$t (wts, Mem$t[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > PIXEL(0.0)) + Mem$t[twts+index-1] = PIXEL(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") +$if (datatype == r) + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") +$else + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") +$endif + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call parg$t (xref[i]) + call parg$t (yref[i]) + call parg$t (xin[i]) + call parg$t (yin[i]) + if (Mem$t[twts+i-1] > 0.0d0) { + call parg$t (xfit[i]) + call parg$t (yfit[i]) + call parg$t (xin[i] - xfit[i]) + call parg$t (yin[i] - yfit[i]) + } else { + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + call parg$t (INDEF) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_show$t (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +PIXEL xshift, yshift, a, b, c, d +PIXEL xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equal$t() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeff$t (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call parg$t (xshift) + call parg$t (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call parg$t (xshift) + call parg$t (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call parg$t (xscale) + call parg$t (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call parg$t (xscale) + call parg$t (yscale) + } + + # Output the rotation factors. + if (fp_equal$t (a, PIXEL(0.0)) && fp_equal$t (c, PIXEL(0.0))) + xrot = PIXEL(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < PIXEL(0.0)) + xrot = xrot + PIXEL(360.0) + if (fp_equal$t (b, PIXEL(0.0)) && fp_equal$t (d, PIXEL(0.0))) + yrot = PIXEL(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < PIXEL(0.0)) + yrot = yrot + PIXEL(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call parg$t (xrot) + call parg$t (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call parg$t (xrot) + call parg$t (yrot) + } + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/immatch/src/geometry/t_geomap.x b/pkg/images/immatch/src/geometry/t_geomap.x new file mode 100644 index 00000000..6f1c20f0 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geomap.x @@ -0,0 +1,1509 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "../../../lib/geomap.h" + +define GM_REAL 1 # computation type is real +define GM_DOUBLE 2 # computation type is double + + + +# T_GEOMAP -- Procedure to calculate the transformation required to transform +# the coordinate system of a reference image to the coordinate system of +# an input image. The transformation is of the following form. +# +# xin = f (xref, yref) +# yin = g (xref, yref) + +procedure t_geomap () + +bool verbose, interactive +double xmin, xmax, ymin, ymax, reject +int geometry, function, calctype, nfiles, list, in, reclist, nrecords +int xxorder, xyorder, xxterms, yxorder, yyorder, yxterms, maxiter +int reslist, nresfiles, res +pointer sp, in_name, str, out, fit, gd, graphics +real rxmin, rxmax, rymin, rymax + +bool clgetb() +double clgetd() +int clgeti(), clgwrd(), clplen(), errget(), imtopenp(), imtlen() +int imtgetim() +pointer clpopnu(), clgfil(), dtmap(), gopen(), open() + +errchk geo_mapr(), geo_mapd() + +begin + # Get working space. + call smark (sp) + call salloc (in_name, SZ_FNAME, TY_CHAR) + call salloc (graphics, SZ_FNAME, TY_CHAR) + call salloc (str, max(SZ_LINE, SZ_FNAME), TY_CHAR) + + # Get input data file(s). + list = clpopnu ("input") + nfiles = clplen (list) + + # Open database output file. + call clgstr ("database", Memc[str], SZ_FNAME) + out = dtmap (Memc[str], APPEND) + + # Get minimum and maximum reference values. + xmin = clgetd ("xmin") + if (IS_INDEFD(xmin)) + rxmin = INDEFR + else + rxmin = xmin + xmax = clgetd ("xmax") + if (IS_INDEFD(xmax)) + rxmax = INDEFR + else + rxmax = xmax + ymin = clgetd ("ymin") + if (IS_INDEFD(ymin)) + rymin = INDEFR + else + rymin = ymin + ymax = clgetd ("ymax") + if (IS_INDEFD(ymax)) + rymax = INDEFR + else + rymax = ymax + + # Get the records list. + reclist = imtopenp ("transforms") + nrecords = imtlen (reclist) + if ((nrecords > 0) && (nrecords != nfiles)) { + call eprintf ( + "The number of records is not equal to the number of input files") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call sfree (sp) + return + } + + # Get the results file list. + reslist = clpopnu ("results") + nresfiles = clplen (reslist) + if (nresfiles > 1 && nresfiles != nfiles) { + call eprintf ("Error: there are too few results files\n") + call clpcls (list) + call dtunmap (out) + call imtclose (reclist) + call clpcls (reslist) + call sfree (sp) + return + } + + # Get the surface fitting parameters. + geometry = clgwrd ("fitgeometry", Memc[str], SZ_LINE, GM_GEOMETRIES) + function = clgwrd ("function", Memc[str], SZ_LINE, GM_FUNCS) + xxorder = clgeti ("xxorder") + xyorder = clgeti ("xyorder") + xxterms = clgwrd ("xxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + yxorder = clgeti ("yxorder") + yyorder = clgeti ("yyorder") + yxterms = clgwrd ("yxterms", Memc[str], SZ_LINE, GM_XFUNCS) - 1 + maxiter = clgeti ("maxiter") + reject = clgetd ("reject") + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, ",real,double,") + + # Get the graphics parameters. + verbose = clgetb ("verbose") + interactive = clgetb ("interactive") + call clgstr ("graphics", Memc[graphics], SZ_FNAME) + + # Flush standard output on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Initialize the fit structure. + call geo_minit (fit, GM_NONE, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + + # Loop over the files. + while (clgfil (list, Memc[in_name], SZ_FNAME) != EOF) { + + # Open text file of coordinates. + in = open (Memc[in_name], READ_ONLY, TEXT_FILE) + + # Open the results files. + if (nresfiles <= 0) + res = NULL + else if (clgfil (reslist, Memc[str], SZ_FNAME) != EOF) + res = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Set file name in structure. + if (nrecords > 0) { + if (imtgetim (reclist, GM_RECORD(fit), SZ_FNAME) != EOF) + ; + } else + call strcpy (Memc[in_name], GM_RECORD(fit), SZ_FNAME) + + if (verbose && res != STDOUT) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("\nCoordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call printf (" Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + if (res != NULL) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call fprintf (res, "\n# Coordinate list: %s Transform: %s\n") + call pargstr (Memc[str]) + call pargstr (GM_RECORD(fit)) + if (res != NULL) + call fstats (res, F_FILENAME, Memc[str], SZ_FNAME) + else + call strcpy ("", Memc[str], SZ_FNAME) + call fprintf (res, "# Results file: %s\n") + call pargstr (Memc[str]) + call flush (STDOUT) + } + + if (interactive) { + gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH) + } else + gd = NULL + + iferr { + if (calctype == GM_REAL) + call geo_mapr (gd, in, out, res, fit, rxmin, rxmax, rymin, + rymax, verbose) + else + call geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, + ymax, verbose) + } then { + if (verbose && res != STDOUT) { + call printf ("Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call printf ("\t%s\n") + call pargstr (Memc[str)) + } + if (res != NULL) { + call fprintf (res, "# Error fitting coordinate list: %s\n") + call pargstr (Memc[in_name]) + call flush (STDOUT) + if (errget (Memc[str], SZ_LINE) == 0) + ; + call fprintf (res, "# %s\n") + call pargstr (Memc[str)) + } + } + + call close (in) + if (nresfiles == nfiles) + call close ( res) + + if (gd != NULL) + call gclose (gd) + } + + # Close up. + call geo_free (fit) + if (nresfiles < nfiles) + call close ( res) + call dtunmap (out) + call imtclose (reclist) + call clpcls (list) + call sfree (sp) +end + + + + + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_mapr (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +real xmin, xmax #I max and min xref values +real ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +real mintemp, maxtemp + +real asumr() +int geo_rdxyr() +errchk geo_fitr, geo_mgfitr() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxyr (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asumr (Memr[xref], npts) / npts) + GM_YOREF(fit) = double (asumr (Memr[yref], npts) / npts) + GM_XOIN(fit) = double (asumr (Memr[xin], npts) / npts) + GM_YOIN(fit) = double (asumr (Memr[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_REAL) + call malloc (yfit, npts, TY_REAL) + call malloc (wts, npts, TY_REAL) + call amovkr (real(1.), Memr[wts], npts) + + # Determine the x max and min. + if (IS_INDEFR(xmin) || IS_INDEFR(xmax)) { + call alimr (Memr[xref], npts, mintemp, maxtemp) + if (! IS_INDEFR(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_INDEFR(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_INDEFR(ymin) || IS_INDEFR(ymax)) { + call alimr (Memr[yref], npts, mintemp, maxtemp) + if (! IS_INDEFR(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_INDEFR(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfitr (gd, fit, sx1, sy1, sx2, sy2, Memr[xref], + Memr[yref], Memr[xin], Memr[yin], Memr[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_REAL) + call mfree (yfit, TY_REAL) + call mfree (wts, TY_REAL) + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fitr (fit, sx1, sy1, sx2, sy2, Memr[xref], + Memr[yref], Memr[xin], Memr[yin], Memr[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_REAL) + call mfree (yfit, TY_REAL) + call mfree (wts, TY_REAL) + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showr (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showr (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_evalr (sx1, sy1, sx2, sy2, Memr[xref], Memr[yref], + Memr[xfit], Memr[yfit], npts) + call geo_plistr (res, fit, Memr[xref], Memr[yref], Memr[xin], + Memr[yin], Memr[xfit], Memr[yfit], Memr[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_REAL) + if (yref != NULL) + call mfree (yref, TY_REAL) + if (xin != NULL) + call mfree (xin, TY_REAL) + if (yin != NULL) + call mfree (yin, TY_REAL) + if (xfit != NULL) + call mfree (xfit, TY_REAL) + if (yfit != NULL) + call mfree (yfit, TY_REAL) + if (wts != NULL) + call mfree (wts, TY_REAL) + + # Output the data. + call geo_moutr (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfreer (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxyr (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +real xmin, xmax # the range of the x coordinates +real ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_REAL) + call malloc (yref, bufsize, TY_REAL) + call malloc (xin, bufsize, TY_REAL) + call malloc (yin, bufsize, TY_REAL) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call gargr (Memr[xref+npts]) + call gargr (Memr[yref+npts]) + call gargr (Memr[xin+npts]) + call gargr (Memr[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_INDEFR(xmin)) { + if (Memr[xref+npts] < xmin) + next + } + if (! IS_INDEFR(xmax)) { + if (Memr[xref+npts] > xmax) + next + } + if (! IS_INDEFR(ymin)) { + if (Memr[yref+npts] < ymin) + next + } + if (! IS_INDEFR(ymax)) { + if (Memr[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_REAL) + call realloc (yref, bufsize, TY_REAL) + call realloc (xin, bufsize, TY_REAL) + call realloc (yin, bufsize, TY_REAL) + } + } + + if (npts <= 0) { + call mfree (xref, TY_REAL) + call mfree (yref, TY_REAL) + call mfree (xin, TY_REAL) + call mfree (yin, TY_REAL) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_REAL) + call realloc (yref, npts, TY_REAL) + call realloc (xin, npts, TY_REAL) + call realloc (yin, npts, TY_REAL) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_evalr (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +real xref[ARB] #I the x reference coordinates +real yref[ARB] #I the y reference coordinates +real xi[ARB] #O the fitted xi coordinates +real eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_REAL) + + call gsvector (sx1, xref, yref, xi, npts) + if (sx2 != NULL) { + call gsvector (sx2, xref, yref, Memr[temp], npts) + call aaddr (Memr[temp], xi, xi, npts) + } + call gsvector (sy1, xref, yref, eta, npts) + if (sy2 != NULL) { + call gsvector (sy2, xref, yref, Memr[temp], npts) + + call aaddr (Memr[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_moutr (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +real xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +int gsgeti() +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeffr (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call pargr (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call pargr (yshift) + call dtput (out, "\txmag\t\t%g\n") + call pargr (xscale) + call dtput (out, "\tymag\t\t%g\n") + call pargr (yscale) + call dtput (out, "\txrotation\t%g\n") + call pargr (xrot) + call dtput (out, "\tyrotation\t%g\n") + call pargr (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call pargr (real(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call pargr (real(yrms)) + + # Allocate memory for linear coefficients. + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call calloc (xcoeff, ncoeff, TY_REAL) + call calloc (ycoeff, ncoeff, TY_REAL) + + # Output the linear coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargr (Memr[xcoeff+i-1]) + call pargr (Memr[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else + ncoeff = gsgeti (sx2, GSNSAVE) + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else + ncoeff = max (gsgeti (sy2, GSNSAVE), ncoeff) + call calloc (xcoeff, ncoeff, TY_REAL) + call calloc (ycoeff, ncoeff, TY_REAL) + + # Save the coefficients. + call gssave (sx2, Memr[xcoeff]) + call gssave (sy2, Memr[ycoeff]) + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargr (Memr[xcoeff+i-1]) + call pargr (Memr[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plistr (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +real xref[ARB] #I the input x coordinates +real yref[ARB] #I the input y coordinates +real xin[ARB] #I the input ra / longitude coordinates +real yin[ARB] #I the input dec / latitude coordinates +real xfit[ARB] #I the fitted ra / longitude coordinates +real yfit[ARB] #I the fitted dec / latitude coordinates +real wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_REAL) + + # Compute the weights. + call amovr (wts, Memr[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > real(0.0)) + Memr[twts+index-1] = real(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + call pargstr ("%9.7g") + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call pargr (xref[i]) + call pargr (yref[i]) + call pargr (xin[i]) + call pargr (yin[i]) + if (Memr[twts+i-1] > 0.0d0) { + call pargr (xfit[i]) + call pargr (yfit[i]) + call pargr (xin[i] - xfit[i]) + call pargr (yin[i] - yfit[i]) + } else { + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_showr (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +real xshift, yshift, a, b, c, d +real xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equalr() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffr (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargr (xshift) + call pargr (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargr (xshift) + call pargr (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargr (xscale) + call pargr (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargr (xscale) + call pargr (yscale) + } + + # Output the rotation factors. + if (fp_equalr (a, real(0.0)) && fp_equalr (c, real(0.0))) + xrot = real(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < real(0.0)) + xrot = xrot + real(360.0) + if (fp_equalr (b, real(0.0)) && fp_equalr (d, real(0.0))) + yrot = real(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < real(0.0)) + yrot = yrot + real(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargr (xrot) + call pargr (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargr (xrot) + call pargr (yrot) + } + + call sfree (sp) +end + + + +# GEO_MAP -- Procedure to calculate the coordinate transformations + +procedure geo_mapd (gd, in, out, res, fit, xmin, xmax, ymin, ymax, verbose) + +pointer gd #I the graphics stream +int in #I the input file descriptor +pointer out #I the output file descriptor +int res #I the results file descriptor +pointer fit #I pointer to fit parameters +double xmin, xmax #I max and min xref values +double ymin, ymax #I max and min yref values +bool verbose #I verbose mode + +int npts, ngood +pointer sp, str, xref, yref, xin, yin, wts, xfit, yfit, xerrmsg, yerrmsg +pointer sx1, sy1, sx2, sy2 +double mintemp, maxtemp + +double asumd() +int geo_rdxyd() +errchk geo_fitd, geo_mgfitd() + +begin + # Get working space. + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (xerrmsg, SZ_LINE, TY_CHAR) + call salloc (yerrmsg, SZ_LINE, TY_CHAR) + + # Initialize pointers. + xref = NULL + yref = NULL + xin = NULL + yin = NULL + wts = NULL + + # Read in data and check that data is in range. + npts = geo_rdxyd (in, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + if (npts <= 0) { + call fstats (in, F_FILENAME, Memc[str], SZ_FNAME) + call printf ("Coordinate list: %s has no data in range.\n") + call pargstr (Memc[str]) + call sfree (sp) + return + } + + # Compute the mean of the reference and input coordinates. + GM_XOREF(fit) = double (asumd (Memd[xref], npts) / npts) + GM_YOREF(fit) = double (asumd (Memd[yref], npts) / npts) + GM_XOIN(fit) = double (asumd (Memd[xin], npts) / npts) + GM_YOIN(fit) = double (asumd (Memd[yin], npts) / npts) + + # Set the reference point for the projections to INDEF. + GM_XREFPT(fit) = INDEFD + GM_YREFPT(fit) = INDEFD + + # Compute the weights. + call malloc (xfit, npts, TY_DOUBLE) + call malloc (yfit, npts, TY_DOUBLE) + call malloc (wts, npts, TY_DOUBLE) + call amovkd (double(1.), Memd[wts], npts) + + # Determine the x max and min. + if (IS_INDEFD(xmin) || IS_INDEFD(xmax)) { + call alimd (Memd[xref], npts, mintemp, maxtemp) + if (! IS_INDEFD(xmin)) + GM_XMIN(fit) = double (xmin) + else + GM_XMIN(fit) = double (mintemp) + if (! IS_INDEFD(xmax)) + GM_XMAX(fit) = double (xmax) + else + GM_XMAX(fit) = double (maxtemp) + } else { + GM_XMIN(fit) = double (xmin) + GM_XMAX(fit) = double (xmax) + } + + # Determine the y max and min. + if (IS_INDEFD(ymin) || IS_INDEFD(ymax)) { + call alimd (Memd[yref], npts, mintemp, maxtemp) + if (! IS_INDEFD(ymin)) + GM_YMIN(fit) = double (ymin) + else + GM_YMIN(fit) = double (mintemp) + if (! IS_INDEFD(ymax)) + GM_YMAX(fit) = double (ymax) + else + GM_YMAX(fit) = double (maxtemp) + } else { + GM_YMIN(fit) = double (ymin) + GM_YMAX(fit) = double (ymax) + } + + # Initalize surface pointers. + sx1 = NULL + sy1 = NULL + sx2 = NULL + sy2 = NULL + + # Fit the data. + if (gd != NULL) { + iferr { + call geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xin], Memd[yin], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call gdeactivate (gd, 0) + call mfree (xfit, TY_DOUBLE) + call mfree (yfit, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + call gdeactivate (gd, 0) + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n") + } + } else { + if (verbose && res != STDOUT) { + call printf ("Coordinate mapping status\n ") + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "# Coordinate mapping status\n# ") + } + iferr { + call geo_fitd (fit, sx1, sy1, sx2, sy2, Memd[xref], + Memd[yref], Memd[xin], Memd[yin], Memd[wts], npts, + Memc[xerrmsg], Memc[yerrmsg], SZ_LINE) + } then { + call mfree (xfit, TY_DOUBLE) + call mfree (yfit, TY_DOUBLE) + call mfree (wts, TY_DOUBLE) + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) + call error (3, "Too few points for X or Y fits.") + } + if (verbose && res != STDOUT) { + call printf ("%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + if (res != NULL) { + call fprintf (res, "%s %s\n") + call pargstr (Memc[xerrmsg]) + call pargstr (Memc[yerrmsg]) + call flush (STDOUT) + } + } + ngood = GM_NPTS(fit) - GM_NWTS0(fit) + if (verbose && res != STDOUT) { + call printf (" Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0d0) + call pargd (0.0d0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showd (STDOUT, fit, sx1, sy1, NO) + } + if (res != NULL) { + call fprintf (res, "# Xin and Yin fit rms: %0.7g %0.7g\n") + if (ngood <= 1) { + call pargd (0.0) + call pargd (0.0) + } else { + call pargd (sqrt (GM_XRMS(fit) / (ngood - 1))) + call pargd (sqrt (GM_YRMS(fit) / (ngood - 1))) + } + call geo_showd (res, fit, sx1, sy1, YES) + } + + # Compute and print the fitted x and y values. + if (res != NULL) { + call geo_evald (sx1, sy1, sx2, sy2, Memd[xref], Memd[yref], + Memd[xfit], Memd[yfit], npts) + call geo_plistd (res, fit, Memd[xref], Memd[yref], Memd[xin], + Memd[yin], Memd[xfit], Memd[yfit], Memd[wts], npts) + } + + # Free the data + if (xref != NULL) + call mfree (xref, TY_DOUBLE) + if (yref != NULL) + call mfree (yref, TY_DOUBLE) + if (xin != NULL) + call mfree (xin, TY_DOUBLE) + if (yin != NULL) + call mfree (yin, TY_DOUBLE) + if (xfit != NULL) + call mfree (xfit, TY_DOUBLE) + if (yfit != NULL) + call mfree (yfit, TY_DOUBLE) + if (wts != NULL) + call mfree (wts, TY_DOUBLE) + + # Output the data. + call geo_moutd (fit, out, sx1, sy1, sx2, sy2) + + # Free the space and close files. + call geo_mmfreed (sx1, sy1, sx2, sy2) + call sfree (sp) +end + + +define GEO_DEFBUFSIZE 1000 # default data buffer sizes + +# GEO_RDXY -- Read in the data points. + +int procedure geo_rdxyd (fd, xref, yref, xin, yin, xmin, xmax, ymin, ymax) + +int fd # the input file descriptor +pointer xref # the x reference coordinates +pointer yref # the y reference coordinates +pointer xin # the x coordinates +pointer yin # the y coordinates +double xmin, xmax # the range of the x coordinates +double ymin, ymax # the range of the y coordinates + +int npts, bufsize +int fscan(), nscan() + +begin + bufsize = GEO_DEFBUFSIZE + call malloc (xref, bufsize, TY_DOUBLE) + call malloc (yref, bufsize, TY_DOUBLE) + call malloc (xin, bufsize, TY_DOUBLE) + call malloc (yin, bufsize, TY_DOUBLE) + + npts = 0 + while (fscan (fd) != EOF) { + + # Decode the data. + call gargd (Memd[xref+npts]) + call gargd (Memd[yref+npts]) + call gargd (Memd[xin+npts]) + call gargd (Memd[yin+npts]) + if (nscan() < 4) + next + + # Check the data limits. + if (! IS_INDEFD(xmin)) { + if (Memd[xref+npts] < xmin) + next + } + if (! IS_INDEFD(xmax)) { + if (Memd[xref+npts] > xmax) + next + } + if (! IS_INDEFD(ymin)) { + if (Memd[yref+npts] < ymin) + next + } + if (! IS_INDEFD(ymax)) { + if (Memd[yref+npts] > ymax) + next + } + + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + GEO_DEFBUFSIZE + call realloc (xref, bufsize, TY_DOUBLE) + call realloc (yref, bufsize, TY_DOUBLE) + call realloc (xin, bufsize, TY_DOUBLE) + call realloc (yin, bufsize, TY_DOUBLE) + } + } + + if (npts <= 0) { + call mfree (xref, TY_DOUBLE) + call mfree (yref, TY_DOUBLE) + call mfree (xin, TY_DOUBLE) + call mfree (yin, TY_DOUBLE) + xref = NULL + yref = NULL + xin = NULL + yin = NULL + } else if (npts < bufsize) { + call realloc (xref, npts, TY_DOUBLE) + call realloc (yref, npts, TY_DOUBLE) + call realloc (xin, npts, TY_DOUBLE) + call realloc (yin, npts, TY_DOUBLE) + } + + return (npts) +end + + +# GEO_EVAL -- Evalute the fit. + +procedure geo_evald (sx1, sy1, sx2, sy2, xref, yref, xi, eta, npts) + +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to higher order surfaces +double xref[ARB] #I the x reference coordinates +double yref[ARB] #I the y reference coordinates +double xi[ARB] #O the fitted xi coordinates +double eta[ARB] #O the fitted eta coordinates +int npts #I the number of points + +pointer sp, temp + +begin + call smark (sp) + call salloc (temp, npts, TY_DOUBLE) + + call dgsvector (sx1, xref, yref, xi, npts) + if (sx2 != NULL) { + call dgsvector (sx2, xref, yref, Memd[temp], npts) + call aaddd (Memd[temp], xi, xi, npts) + } + call dgsvector (sy1, xref, yref, eta, npts) + if (sy2 != NULL) { + call dgsvector (sy2, xref, yref, Memd[temp], npts) + + call aaddd (Memd[temp], eta, eta, npts) + } + + call sfree (sp) +end + + +# GEO_MOUT -- Write the output database file. + +procedure geo_moutd (fit, out, sx1, sy1, sx2, sy2) + +pointer fit #I pointer to fitting structure +int out #I pointer to database file +pointer sx1, sy1 #I pointer to linear surfaces +pointer sx2, sy2 #I pointer to distortion surfaces + +int i, npts, ncoeff +pointer sp, str, xcoeff, ycoeff +double xrms, yrms, xshift, yshift, xscale, yscale, xrot, yrot +int dgsgeti() +int rg_wrdstr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Compute the x and y fit rms. + #npts = max (0, GM_NPTS(fit) - GM_NREJECT(fit) - GM_NWTS0(fit)) + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0d0 + yrms = 0.0d0 + } + + # Print title. + call dtptime (out) + call dtput (out, "begin\t%s\n") + call pargstr (GM_RECORD(fit)) + + # Print the x and y mean values. + call dtput (out, "\txrefmean\t%g\n") + call pargd (GM_XOREF(fit)) + call dtput (out, "\tyrefmean\t%g\n") + call pargd (GM_YOREF(fit)) + call dtput (out, "\txmean\t\t%g\n") + call pargd (GM_XOIN(fit)) + call dtput (out, "\tymean\t\t%g\n") + call pargd (GM_YOIN(fit)) + + # Print some of the fitting parameters. + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call dtput (out, "\tgeometry\t%s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call dtput (out, "\tfunction\t%s\n") + call pargstr (Memc[str]) + + # Output the geometric parameters. + call geo_lcoeffd (sx1, sy1, xshift, yshift, xscale, yscale, xrot, yrot) + call dtput (out, "\txshift\t\t%g\n") + call pargd (xshift) + call dtput (out, "\tyshift\t\t%g\n") + call pargd (yshift) + call dtput (out, "\txmag\t\t%g\n") + call pargd (xscale) + call dtput (out, "\tymag\t\t%g\n") + call pargd (yscale) + call dtput (out, "\txrotation\t%g\n") + call pargd (xrot) + call dtput (out, "\tyrotation\t%g\n") + call pargd (yrot) + + # Out the rms values. + call dtput (out, "\txrms\t\t%g\n") + call pargd (double(xrms)) + call dtput (out, "\tyrms\t\t%g\n") + call pargd (double(yrms)) + + # Allocate memory for linear coefficients. + ncoeff = max (dgsgeti (sx1, GSNSAVE), dgsgeti (sy1, GSNSAVE)) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Output the linear coefficients. + call dgssave (sx1, Memd[xcoeff]) + call dgssave (sy1, Memd[ycoeff]) + call dtput (out, "\tsurface1\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + + # Allocate memory for higer order coefficients. + if (sx2 == NULL) + ncoeff = 0 + else + ncoeff = dgsgeti (sx2, GSNSAVE) + if (sy2 == NULL) + ncoeff = max (0, ncoeff) + else + ncoeff = max (dgsgeti (sy2, GSNSAVE), ncoeff) + call calloc (xcoeff, ncoeff, TY_DOUBLE) + call calloc (ycoeff, ncoeff, TY_DOUBLE) + + # Save the coefficients. + call dgssave (sx2, Memd[xcoeff]) + call dgssave (sy2, Memd[ycoeff]) + + # Output the coefficients. + call dtput (out, "\tsurface2\t%d\n") + call pargi (ncoeff) + do i = 1, ncoeff { + call dtput (out, "\t\t\t%g\t%g\n") + call pargd (Memd[xcoeff+i-1]) + call pargd (Memd[ycoeff+i-1]) + } + + # Cleanup. + call mfree (xcoeff, TY_DOUBLE) + call mfree (ycoeff, TY_DOUBLE) + call sfree (sp) +end + + +# GEO_PLIST -- Print the input, output, and fitted data and the residuals. + +procedure geo_plistd (fd, fit, xref, yref, xin, yin, xfit, yfit, wts, npts) + +int fd #I the results file descriptor +pointer fit #I pointer to the fit structure +double xref[ARB] #I the input x coordinates +double yref[ARB] #I the input y coordinates +double xin[ARB] #I the input ra / longitude coordinates +double yin[ARB] #I the input dec / latitude coordinates +double xfit[ARB] #I the fitted ra / longitude coordinates +double yfit[ARB] #I the fitted dec / latitude coordinates +double wts[ARB] #I the weights array +int npts #I the number of data points + +int i, index +pointer sp, fmtstr, twts + +begin + # Allocate working space. + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + call salloc (twts, npts, TY_DOUBLE) + + # Compute the weights. + call amovd (wts, Memd[twts], npts) + do i = 1, GM_NREJECT(fit) { + index = Memi[GM_REJ(fit)+i-1] + if (wts[index] > double(0.0)) + Memd[twts+index-1] = double(0.0) + } + + # Print banner. + call fprintf (fd, "\n# Input Coordinate Listing\n") + call fprintf (fd, "# Column 1: X (reference) \n") + call fprintf (fd, "# Column 2: Y (reference)\n") + call fprintf (fd, "# Column 3: X (input)\n") + call fprintf (fd, "# Column 4: Y (input)\n") + call fprintf (fd, "# Column 5: X (fit)\n") + call fprintf (fd, "# Column 6: Y (fit)\n") + call fprintf (fd, "# Column 7: X (residual)\n") + call fprintf (fd, "# Column 8: Y (residual)\n\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s %s %s\n") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + call pargstr ("%16.14g") + + # Print the data. + do i = 1, npts { + call fprintf (fd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + if (Memd[twts+i-1] > 0.0d0) { + call pargd (xfit[i]) + call pargd (yfit[i]) + call pargd (xin[i] - xfit[i]) + call pargd (yin[i] - yfit[i]) + } else { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } + + } + + call fprintf (fd, "\n") + + call sfree (sp) + +end + +# GEO_SHOW -- Print the coordinate mapping parameters. + +procedure geo_showd (fd, fit, sx1, sy1, comment) + +int fd #I the output file descriptor +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointer to linear surfaces +int comment #I comment the output ? + +double xshift, yshift, a, b, c, d +double xscale, yscale, xrot, yrot +pointer sp, str +bool fp_equald() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Compute the geometric parameters. + call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) + + if (comment == NO) { + call fprintf (fd, "Coordinate mapping parameters\n") + } else { + call fprintf (fd, "# Coordinate mapping parameters\n") + } + + if (comment == NO) { + call fprintf (fd, + " Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + " Mean Xin and Yin: %0.7g %0.7g\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + " X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargd (xshift) + call pargd (yshift) + } else { + call fprintf (fd, + "# Mean Xref and Yref: %0.7g %0.7g\n") + call pargd (GM_XOREF(fit)) + call pargd (GM_YOREF(fit)) + call fprintf (fd, + "# Mean Xin and Yin: %0.7g %g0.7\n") + call pargd (GM_XOIN(fit)) + call pargd (GM_YOIN(fit)) + call fprintf (fd, + "# X and Y shift: %0.7g %0.7g (xin yin)\n") + call pargd (xshift) + call pargd (yshift) + } + + # Output the scale factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + if (comment == NO) { + call fprintf (fd, + " X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargd (xscale) + call pargd (yscale) + } else { + call fprintf (fd, + "# X and Y scale: %0.7g %0.7g (xin / xref yin / yref)\n") + call pargd (xscale) + call pargd (yscale) + } + + # Output the rotation factors. + if (fp_equald (a, double(0.0)) && fp_equald (c, double(0.0))) + xrot = double(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < double(0.0)) + xrot = xrot + double(360.0) + if (fp_equald (b, double(0.0)) && fp_equald (d, double(0.0))) + yrot = double(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < double(0.0)) + yrot = yrot + double(360.0) + if (comment == NO) { + call fprintf (fd, + " X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } else { + call fprintf (fd, + "# X and Y axis rotation: %0.5f %0.5f (degrees degrees)\n") + call pargd (xrot) + call pargd (yrot) + } + + call sfree (sp) +end + + diff --git a/pkg/images/immatch/src/geometry/t_geotran.x b/pkg/images/immatch/src/geometry/t_geotran.x new file mode 100644 index 00000000..5e5cd2e3 --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geotran.x @@ -0,0 +1,880 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "geotran.h" + +# T_GEOTRAN -- Geometrically transform a list of images either linearly or +# using a transformation computed by the GEOMAP task. + +procedure t_geotran () + +int ncols, nlines # output picture size +real xmin, xmax, ymin, ymax # minimum and maximum ref values +real xscale, yscale # output picture scale +real xin, yin # input picture origin +real xshift, yshift # x and y shifts +real xout, yout # output picture origin +real xmag, ymag # input picture scale +real xrotation, yrotation # rotation angle +int nxblock, nyblock # block size of image to be used + +bool verbose +int list1, list2, tflist, ndim, nc, nl, mode +pointer sp, imtlist1, imtlist2, database, transform, record +pointer image1, image2, imtemp, imroot, section, str +pointer geo, sx1, sy1, sx2, sy2, in, out, mw +real xs, ys, txshift, tyshift, txmag, tymag, txrot, tyrot +double oltv[2], nltv[2], oltm[2,2], nltm[2,2] + +bool clgetb(), envgetb(), streq() +int imtopen(), imtlen(), clgeti(), imtgetim(), clgwrd(), btoi() +pointer immap(), mw_openim() +real clgetr() +errchk immap() + +begin + # Set up the geotran structure. + call smark (sp) + call salloc (imtlist1, SZ_LINE, TY_CHAR) + call salloc (imtlist2, SZ_LINE, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (transform, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (imroot, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (geo, LEN_GEOSTRUCT, TY_STRUCT) + + # Get the input and output lists and database file. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + call clgstr ("database", Memc[database], SZ_FNAME) + if (Memc[database] != EOS) { + call clgstr ("transforms", Memc[transform], SZ_FNAME) + tflist = imtopen (Memc[transform]) + GT_GEOMODE(geo) = clgwrd ("geometry", Memc[str], SZ_LINE, + ",junk,linear,distortion,geometric,") + } else { + tflist = NULL + GT_GEOMODE(geo) = GT_NONE + } + + # Get the output picture format parameters. + xmin = clgetr ("xmin") + xmax = clgetr ("xmax") + ymin = clgetr ("ymin") + ymax = clgetr ("ymax") + xscale = clgetr ("xscale") + yscale = clgetr ("yscale") + ncols= clgeti ("ncols") + nlines = clgeti ("nlines") + + # Get the geometric transformation parameters. + xin = clgetr ("xin") + yin = clgetr ("yin") + xshift = clgetr ("xshift") + yshift = clgetr ("yshift") + xout = clgetr ("xout") + yout = clgetr ("yout") + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + xrotation = clgetr ("xrotation") + yrotation = clgetr ("yrotation") + + # Get the interpolation parameters. + call clgstr ("interpolant", GT_INTERPSTR(geo), SZ_FNAME) + #GT_INTERPOLANT(geo) = clgwrd ("interpolant", Memc[str], SZ_LINE, + #",nearest,linear,poly3,poly5,spline3,") + GT_BOUNDARY(geo) = clgwrd ("boundary", Memc[str], SZ_LINE, + ",constant,nearest,reflect,wrap,") + GT_CONSTANT(geo) = clgetr ("constant") + GT_XSAMPLE(geo) = clgetr ("xsample") + GT_YSAMPLE(geo) = clgetr ("ysample") + GT_FLUXCONSERVE(geo) = btoi (clgetb("fluxconserve")) + + nxblock = clgeti ("nxblock") + nyblock = clgeti ("nyblock") + verbose = clgetb ("verbose") + + # Open the lists of images and check the scale lengths. + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + if (tflist != NULL) + call imtclose (tflist) + call error (0, "Input and output lists not the same length.") + } + + # Check the transform list. + if (tflist != NULL) { + if (imtlen (tflist) > 1 && imtlen (tflist) != imtlen (list1)) { + call imtclose (list1) + call imtclose (list2) + call imtclose (tflist) + call error (0, "Transform and input lists not the same length.") + } + } + + # Loop over the images. + if (verbose) { + call printf ("\n") + } + while (imtgetim (list1, Memc[image1], SZ_FNAME) != EOF && + imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + + # Print messages. + if (verbose) { + call printf ("Transforming image %s to image %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image2]) + call flush (STDOUT) + } + + # Open the images. + in = immap (Memc[image1], READ_ONLY, 0) + call imgimage (Memc[image1], Memc[str], SZ_FNAME) + call imgimage (Memc[image2], Memc[imroot], SZ_FNAME) + call imgsection (Memc[image2], Memc[section], SZ_FNAME) + if (streq (Memc[str], Memc[imroot])) { + call strcpy (Memc[imroot], Memc[imtemp], SZ_FNAME) + call mktemp ("tmp", Memc[image2], SZ_FNAME) + } else + call strcpy (Memc[image2], Memc[imtemp], SZ_FNAME) + ifnoerr (out = immap (Memc[image2], READ_WRITE, 0)) { + mode = READ_WRITE + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + xs = INDEF + ys = INDEF + } else if (Memc[section] != EOS) { + mode = NEW_IMAGE + out = immap (Memc[imroot], NEW_IMAGE, 0) + IM_NDIM(out) = IM_NDIM(in) + if (IS_INDEFI(ncols)) + IM_LEN(out,1) = IM_LEN(in,1) + else + IM_LEN(out,1) = ncols + if (IS_INDEFI(nlines)) + IM_LEN(out,2) = IM_LEN(in,2) + else + IM_LEN(out,2) = nlines + IM_PIXTYPE(out) = IM_PIXTYPE(in) + call geo_imzero (out, GT_CONSTANT(geo)) + call imunmap (out) + out = immap (Memc[image2], READ_WRITE, 0) + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + xs = INDEF + ys = INDEF + } else { + mode = NEW_COPY + out = immap (Memc[image2], NEW_COPY, in) + nc = ncols + nl = nlines + xs = xscale + ys = yscale + } + + # Set the geometry parameters. + call geo_set (geo, xmin, xmax, ymin, ymax, xs, ys, nc, nl, xin, + yin, xshift, yshift, xout, yout, xmag, ymag, xrotation, + yrotation) + + # Get the coordinate surfaces. + if (GT_GEOMODE(geo) == GT_NONE) { + call geo_format (in, out, geo, sx1, sy1, sx2, sy2) + if (verbose) { + call geo_lcoeffr (sx1, sy1, txshift, tyshift, txmag, + tymag, txrot, tyrot) + call printf (" xshift: %.2f yshift: %.2f ") + call pargr (txshift) + call pargr (tyshift) + call printf ("xmag: %.2f ymag: %.2f ") + call pargr (txmag) + call pargr (tymag) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargr (txrot) + call pargr (tyrot) + call flush (STDOUT) + } + } else { + if (imtgetim (tflist, Memc[str], SZ_FNAME) != EOF) + call strcpy (Memc[str], Memc[record], SZ_FNAME) + call geo_dformat (in, out, geo, Memc[database], Memc[record], + sx1, sy1, sx2, sy2) + if (verbose) { + call printf (" Using transform %s in database %s\n") + call pargstr (Memc[record]) + call pargstr (Memc[database]) + call flush (STDOUT) + } + } + + # Transform the image. + if (IM_LEN(out,1) <= nxblock && IM_LEN(out,2) <= nyblock) { + if (GT_XSAMPLE(geo) > 1.0 || GT_YSAMPLE(geo) > 1.0) + call geo_simtran (in, out, geo, sx1, sy1, sx2, sy2) + else + call geo_imtran (in, out, geo, sx1, sy1, sx2, sy2) + } else { + if (GT_XSAMPLE(geo) > 1.0 || GT_YSAMPLE(geo) > 1.0) { + if (IM_NDIM(out) == 1) + call geo_stran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, 1) + else + call geo_stran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, nyblock) + } else { + if (IM_NDIM(out) == 1) + call geo_tran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, 1) + else + call geo_tran (in, out, geo, sx1, sy1, sx2, sy2, + nxblock, nyblock) + } + } + + # Update the linear part of the wcs. + if (!envgetb ("nomwcs") && mode == NEW_COPY) { + ndim = IM_NDIM(in) + mw = mw_openim (in) + call geo_gwcs (geo, sx1, sy1, oltm, oltv) + call mw_invertd (oltm, nltm, ndim) + call mw_vmuld (nltm, oltv, nltv, ndim) + call anegd (nltv, nltv, ndim) + call geo_swcs (mw, nltm, nltv, ndim) + call mw_saveim (mw, out) + call mw_close (mw) + } + + # Free the surfaces. + call gsfree (sx1) + call gsfree (sy1) + call gsfree (sx2) + call gsfree (sy2) + + # Close the images. + call imunmap (in) + call imunmap (out) + + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + # Clean up. + call sfree (sp) + if (tflist != NULL) + call imtclose (tflist) + call imtclose (list1) + call imtclose (list2) +end + + +# GEO_IMZERO -- Create a dummy output image filled with the constant boundary +# extension value. + +procedure geo_imzero (im, constant) + +pointer im #I pointer to the input image +real constant #I the constant value to insert in the imagw + +int npix +pointer sp, v, buf +int impnls(), impnll(), impnlr(), impnld(), impnlx() + +begin + # Setup start vector for sequential reads and writes. + call smark (sp) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v], IM_MAXDIM) + + # Initialize the image. + npix = IM_LEN(im, 1) + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (impnls (im, buf, Meml[v]) != EOF) + call amovks (short (constant), Mems[buf], npix) + case TY_USHORT, TY_INT, TY_LONG: + while (impnll (im, buf, Meml[v]) != EOF) + call amovkl (long (constant), Meml[buf], npix) + case TY_REAL: + while (impnlr (im, buf, Meml[v]) != EOF) + call amovkr (constant, Memr[buf], npix) + case TY_DOUBLE: + while (impnld (im, buf, Meml[v]) != EOF) + call amovkd (double (constant), Memd[buf], npix) + case TY_COMPLEX: + while (impnlx (im, buf, Meml[v]) != EOF) + call amovkx (complex (constant, 0.0), Memx[buf], npix) + default: + call error (1, "Unknown pixel datatype") + } + + call sfree (sp) +end + + +# GEO_SET -- Set the image dependent task parameters individually for each +# image. + +procedure geo_set (geo, xmin, xmax, ymin, ymax, xscale, yscale, ncols, nlines, + xin, yin, xshift, yshift, xout, yout, xmag, ymag, xrotation, yrotation) + +pointer geo #I pointer to geotran structure +real xmin, xmax #I minimum and maximum reference values +real ymin, ymax #I minimum and maximum reference values +real xscale, yscale #I output picture scale +int ncols, nlines #I output picture size +real xin, yin #I input picture pixel coordinates +real xshift, yshift #I shift of origin +real xout, yout #I corresponding output picture coords +real xmag, ymag #I input picture scale +real xrotation, yrotation #I scale angle + +begin + # Set the output picture format parameters. + GT_XMIN(geo) = xmin + GT_XMAX(geo) = xmax + GT_YMIN(geo) = ymin + GT_YMAX(geo) = ymax + GT_XSCALE(geo) = xscale + GT_YSCALE(geo) = yscale + GT_NCOLS(geo) = ncols + GT_NLINES(geo) = nlines + + # Set the transformation parameters. + GT_XIN(geo) = xin + GT_YIN(geo) = yin + GT_XSHIFT(geo) = xshift + GT_YSHIFT(geo) = yshift + GT_XOUT(geo) = xout + GT_YOUT(geo) = yout + GT_XMAG(geo) = xmag + GT_YMAG(geo) = ymag + GT_XROTATION(geo) = xrotation + GT_YROTATION(geo) = yrotation +end + + +# GEO_FORMAT -- Format the output picture when there is no database file. + +procedure geo_format (in, out, geo, sx1, sy1, sx2, sy2) + +pointer in #I pointer to the input image +pointer out #I pointer to the ouput image +pointer geo #I pointer to the geotran structure +pointer sx1, sy1 #O pointer to linear surfaces +pointer sx2, sy2 #O pointer to distortion surfaces + +real xmax, ymax + +begin + # Get the scale transformation parameters. + if (IS_INDEFR(GT_XMAG(geo))) + GT_XMAG(geo) = 1. + if (IM_NDIM(in) == 1) + GT_YMAG(geo) = 1. + else if (IS_INDEFR(GT_YMAG(geo))) + GT_YMAG(geo) = 1. + + # Get the rotate transformation parameters. + if (IM_NDIM(in) == 1) + GT_XROTATION(geo) = DEGTORAD(0.) + else if (IS_INDEFR(GT_XROTATION(geo))) + GT_XROTATION(geo) = DEGTORAD(0.) + else + GT_XROTATION(geo) = DEGTORAD(GT_XROTATION(geo)) + if (IM_NDIM(in) == 1) + GT_YROTATION(geo) = DEGTORAD(0.) + else if (IS_INDEFR(GT_YROTATION(geo))) + GT_YROTATION(geo) = DEGTORAD(0.) + else + GT_YROTATION(geo) = DEGTORAD(GT_YROTATION(geo)) + + # Automatically compute the maximum extent of the image. + if (GT_XMAX(geo) <= 0.0 || GT_YMAX(geo) <= 0.0) { + + # Compute the size of the output image. + xmax = abs (cos(GT_XROTATION(geo)) * IM_LEN(in,1) / + GT_XMAG(geo)) + abs(sin(GT_YROTATION(geo)) * IM_LEN(in,2) / + GT_YMAG(geo)) + ymax = abs (sin(GT_XROTATION(geo)) * IM_LEN(in, 1) / + GT_XMAG(geo)) + abs (cos(GT_YROTATION(geo)) * IM_LEN(in,2) / + GT_YMAG(geo)) + } + + # Set up the x reference coordinate limits. + if (IS_INDEF(GT_XMIN(geo))) + GT_XMIN(geo) = 1. + else + GT_XMIN(geo) = max (1.0, GT_XMIN(geo)) + if (IS_INDEF(GT_XMAX(geo))) + GT_XMAX(geo) = IM_LEN(in,1) + else if (GT_XMAX(geo) <= 0.0) + #GT_XMAX(geo) = int (xmax + 1.0) + GT_XMAX(geo) = xmax + + # Set up the y reference coordinate limits. + if (IS_INDEF(GT_YMIN(geo))) + GT_YMIN(geo) = 1. + else + GT_YMIN(geo) = max (1.0, GT_YMIN(geo)) + if (IS_INDEF(GT_YMAX(geo))) + GT_YMAX(geo) = IM_LEN(in, 2) + else if (GT_YMAX(geo) <= 0.0) + #GT_YMAX(geo) = int (ymax + 1.0) + GT_YMAX(geo) = ymax + + # Set the number of columns and rows. + if (IS_INDEFI(GT_NCOLS(geo))) + GT_NCOLS(geo) = IM_LEN(in, 1) + if (IM_NDIM(in) == 1) + GT_NLINES(geo) = 1 + else if (IS_INDEFI(GT_NLINES(geo))) + GT_NLINES(geo) = IM_LEN(in, 2) + + # Set scale, overiding number of columns and rows if necessary. + if (IS_INDEFR(GT_XSCALE(geo))) + GT_XSCALE(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / (GT_NCOLS(geo) - 1) + else + GT_NCOLS(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / GT_XSCALE(geo) + 1 + if (IM_NDIM(in) == 1) + GT_YSCALE(geo) = 1.0 + else if (IS_INDEFR(GT_YSCALE(geo))) + GT_YSCALE(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / + (GT_NLINES(geo) - 1) + else + GT_NLINES(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / GT_YSCALE(geo) + 1 + IM_LEN(out, 1) = GT_NCOLS(geo) + IM_LEN(out, 2) = GT_NLINES(geo) + + # Set up the surfaces, distortion surfaces are NULL. + if (IM_NDIM(in) == 1) { + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), 0.5, 1.5) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), 0.5, 1.5) + } else { + call gsinit (sx1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), GT_YMIN(geo), GT_YMAX(geo)) + call gsinit (sy1, GS_POLYNOMIAL, 2, 2, GS_XNONE, GT_XMIN(geo), + GT_XMAX(geo), GT_YMIN(geo), GT_YMAX(geo)) + } + sx2 = NULL + sy2 = NULL + + # Adjust rotation, x and y scale, scale angle, and flip. + call geo_rotmagr (sx1, sy1, GT_XMAG(geo), GT_YMAG(geo), + GT_XROTATION(geo), GT_YROTATION(geo)) + + # Adjust the shift. + call geo_shift (in, out, geo, sx1, sy1) +end + + +# GEO_DFORMAT -- Get the coordinate transformation from a database file. + +procedure geo_dformat (in, out, geo, database, transform, sx1, sy1, sx2, sy2) + +pointer in, out #I pointers to input and output images +pointer geo #I pointer to geotran structure +char database[ARB] #I name of database file +char transform[ARB] #I name of transform +pointer sx1, sy1 #O pointer to linear part of surface fit +pointer sx2, sy2 #O pointer to higher order surface + +int i, dt, rec, ncoeff, junk +pointer xcoeff, ycoeff, newsx1, newsy1 +int dtmap(), dtlocate(), dtgeti(), dtscan() +errchk gsrestore + +begin + # Map the database and locate the transformation record. + dt = dtmap (database, READ_ONLY) + rec = dtlocate (dt, transform) + + # Get the linear part of the fit. + ncoeff = dtgeti (dt, rec, "surface1") + call malloc (xcoeff, ncoeff, TY_REAL) + call malloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan (dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + call gsrestore (sx1, Memr[xcoeff]) + call gsrestore (sy1, Memr[ycoeff]) + + # Set the output image format parameters. + call geo_dout (in, out, geo, sx1, sy1) + + # Adjust the linear part of the fit. + call gscopy (sx1, newsx1) + call gscopy (sy1, newsy1) + if (GT_GEOMODE(geo) == GT_DISTORT) + call geo_rotmagr (newsx1, newsy1, 1.0, 1.0, 0.0, 0.0) + else if (! IS_INDEFR(GT_XMAG(geo)) || ! IS_INDEFR(GT_YMAG(geo)) || + ! IS_INDEFR(GT_XROTATION(geo)) || ! IS_INDEFR(GT_YROTATION(geo))) + call geo_dcoeff (geo, dt, rec, newsx1, newsy1) + call geo_dshift (in, out, dt, rec, geo, newsx1, newsy1) + + # Get the higher order part of the fit. + ncoeff = dtgeti (dt, rec, "surface2") + if (ncoeff > 0 && (GT_GEOMODE(geo) == GT_GEOMETRIC || GT_GEOMODE(geo) == + GT_DISTORT)) { + + # Get the distortion coefficients. + call realloc (xcoeff, ncoeff, TY_REAL) + call realloc (ycoeff, ncoeff, TY_REAL) + do i = 1, ncoeff { + junk = dtscan(dt) + call gargr (Memr[xcoeff+i-1]) + call gargr (Memr[ycoeff+i-1]) + } + iferr { + call gsrestore (sx2, Memr[xcoeff]) + } then { + call mfree (sx2, TY_STRUCT) + sx2 = NULL + } + iferr { + call gsrestore (sy2, Memr[ycoeff]) + } then { + call mfree (sy2, TY_STRUCT) + sy2 = NULL + } + + } else { + + sx2 = NULL + sy2 = NULL + } + + # Redefine the surfaces. + call gsfree (sx1) + call gscopy (newsx1, sx1) + call gsfree (newsx1) + call gsfree (sy1) + call gscopy (newsy1, sy1) + call gsfree (newsy1) + + # Cleanup. + call mfree (xcoeff, TY_REAL) + call mfree (ycoeff, TY_REAL) + call dtunmap (dt) +end + + +# GEO_DOUT -- Set the output image format using information in the database +# file. + +procedure geo_dout (in, out, geo, sx1, sy1) + +pointer in, out #I pointers to input and output image +pointer geo #I pointer to geotran sturcture +pointer sx1, sy1 #I pointers to linear surface descriptors + +real gsgetr () + +begin + # Set the reference coordinate limits. + if (IS_INDEFR(GT_XMIN(geo))) + GT_XMIN(geo) = gsgetr (sx1, GSXMIN) + if (IS_INDEFR(GT_XMAX(geo))) + GT_XMAX(geo) = gsgetr (sx1, GSXMAX) + if (IS_INDEFR(GT_YMIN(geo))) + GT_YMIN(geo) = gsgetr (sy1, GSYMIN) + if (IS_INDEFR(GT_YMAX(geo))) + GT_YMAX(geo) = gsgetr (sy1, GSYMAX) + + # Set the number of lines and columns. + if (IS_INDEFI(GT_NCOLS(geo))) + GT_NCOLS(geo) = IM_LEN(in, 1) + if (IM_NDIM(in) == 1) + GT_NLINES(geo) = 1 + else if (IS_INDEFI(GT_NLINES(geo))) + GT_NLINES(geo) = IM_LEN(in, 2) + + # Set scale, overiding the number of columns and rows if necessary. + if (IS_INDEFR(GT_XSCALE(geo))) + GT_XSCALE(geo) = (GT_XMAX(geo) - GT_XMIN(geo)) / (GT_NCOLS(geo) - 1) + else + GT_NCOLS(geo) = abs ((GT_XMAX(geo) - GT_XMIN(geo)) / + GT_XSCALE(geo)) + 1 + if (IM_NDIM(in) == 1) + GT_YSCALE(geo) = 1.0 + else if (IS_INDEFR(GT_YSCALE(geo))) + GT_YSCALE(geo) = (GT_YMAX(geo) - GT_YMIN(geo)) / + (GT_NLINES(geo) - 1) + else + GT_NLINES(geo) = abs ((GT_YMAX(geo) - GT_YMIN(geo)) / + GT_YSCALE(geo)) + 1 + + # Set the output image size. + IM_LEN(out,1) = GT_NCOLS(geo) + IM_LEN(out,2) = GT_NLINES(geo) +end + + +# GEO_DSHIFT -- Adjust the shifts using information in the database file. + +procedure geo_dshift (in, out, dt, rec, geo, sx1, sy1) + +pointer in, out #I pointer to input and output images +pointer dt #I pointer to database +int rec #I pointer to database record +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #U pointers to linear surfaces + +real gseval() + +begin + # Define the output origin. + if (IS_INDEFR(GT_XOUT(geo))) + GT_XOUT(geo) = (GT_XMAX(geo) + GT_XMIN(geo)) / 2.0 + if (IS_INDEFR(GT_YOUT(geo))) + GT_YOUT(geo) = (GT_YMAX(geo) + GT_YMIN(geo)) / 2.0 + + # Define the input image origin. + if (IS_INDEFR(GT_XIN(geo))) + GT_XIN(geo) = gseval (sx1, GT_XOUT(geo), GT_YOUT(geo)) + if (IS_INDEFR(GT_YIN(geo))) + GT_YIN(geo) = gseval (sy1, GT_XOUT(geo), GT_YOUT(geo)) + + # Define the shifts. + if (IS_INDEFR(GT_XSHIFT(geo))) + GT_XSHIFT(geo) = GT_XIN(geo) - gseval (sx1, GT_XOUT(geo), + GT_YOUT(geo)) + if (IS_INDEFR(GT_YSHIFT(geo))) + GT_YSHIFT(geo) = GT_YIN(geo) - gseval (sy1, GT_XOUT(geo), + GT_YOUT(geo)) + + # Correct the coefficients. + call geo_xyshiftr (sx1, sy1, GT_XSHIFT(geo), GT_YSHIFT(geo)) +end + + +# GEO_SHIFT -- Compute the shift. + +procedure geo_shift (in, out, geo, sx1, sy1) + +pointer in, out #I pointer to input and output images +pointer geo #I pointer to geotran structure +pointer sx1, sy1 #I pointers to linear surfaces + +real gseval() + +begin + # Determine the output origin. + if (IS_INDEFR(GT_XOUT(geo))) + GT_XOUT(geo) = (GT_XMAX(geo) + GT_XMIN(geo)) / 2.0 + if (IS_INDEFR(GT_YOUT(geo))) + GT_YOUT(geo) = (GT_YMAX(geo) + GT_YMIN(geo)) / 2.0 + + # Determine the input origin. + if (IS_INDEFR(GT_XIN(geo))) + GT_XIN(geo) = (real (IM_LEN (in, 1)) + 1.) / 2. + if (IS_INDEFR(GT_YIN(geo))) + GT_YIN(geo) = (real (IM_LEN (in, 2)) + 1.) / 2. + + # Determine the final x and y shifts. + if (! IS_INDEFR(GT_XSHIFT(geo))) + GT_XOUT(geo) = GT_XIN(geo) + GT_XSHIFT(geo) + if (! IS_INDEFR(GT_YSHIFT(geo))) + GT_YOUT(geo) = GT_YIN(geo) + GT_YSHIFT(geo) + GT_XSHIFT(geo) = GT_XIN(geo) - gseval (sx1, GT_XOUT(geo), + GT_YOUT(geo)) + GT_YSHIFT(geo) = GT_YIN(geo) - gseval (sy1, GT_XOUT(geo), + GT_YOUT(geo)) + + # Alter coefficients. + call geo_xyshiftr (sx1, sy1, GT_XSHIFT(geo), GT_YSHIFT(geo)) +end + + +# GEO_DCOEFF -- Alter the linear componets of the surface fit after the fact. + +procedure geo_dcoeff (geo, dt, rec, sx1, sy1) + +pointer geo #I pointer to geotran structure +pointer dt #I pointer to database record +int rec #I database record +pointer sx1, sy1 #U pointers to the linear surface + +real dtgetr() +errchk dtgetr() + +begin + # Get the transformation parameters. + if (IS_INDEFR(GT_XMAG(geo))) { + iferr (GT_XMAG(geo) = dtgetr (dt, rec, "xmag")) + GT_XMAG(geo) = dtgetr (dt, rec, "xscale") + } + if (IS_INDEFR(GT_YMAG(geo))) { + iferr (GT_YMAG(geo) = dtgetr (dt, rec, "ymag")) + GT_YMAG(geo) = dtgetr (dt, rec, "yscale") + } + if (IS_INDEFR(GT_XROTATION(geo))) + GT_XROTATION(geo) = DEGTORAD(dtgetr (dt, rec, "xrotation")) + else + GT_XROTATION(geo) = DEGTORAD(GT_XROTATION(geo)) + if (IS_INDEFR(GT_YROTATION(geo))) + GT_YROTATION(geo) = DEGTORAD(dtgetr (dt, rec, "yrotation")) + else + GT_YROTATION(geo) = DEGTORAD(GT_YROTATION(geo)) + + call geo_rotmagr (sx1, sy1, GT_XMAG(geo), GT_YMAG(geo), + GT_XROTATION(geo), GT_YROTATION(geo)) +end + + +# GEO_GWCS -- Compute the ltm and ltv vectors using the GEOTRAN coordinate +# surfaces. + +procedure geo_gwcs (geo, sx1, sy1, ltm, ltv) + +pointer geo # pointer to the geotran structure +pointer sx1 # pointer to the linear x coordinate surface +pointer sy1 # pointer to the linear y coordinate surface +double ltm[2,2] # rotation matrix +double ltv[2] # shift vector + +double xscale, yscale, xmin, ymin +int ncoeff +pointer sp, xcoeff, ycoeff +real xrange, yrange +int gsgeti() +real gsgetr() + +begin + # Allocate space for the coefficients. + call smark (sp) + ncoeff = max (gsgeti (sx1, GSNSAVE), gsgeti (sy1, GSNSAVE)) + call salloc (xcoeff, ncoeff, TY_REAL) + call salloc (ycoeff, ncoeff, TY_REAL) + + # Fetch the coefficients. + call gssave (sx1, Memr[xcoeff]) + call gssave (sy1, Memr[ycoeff]) + + # Denormalize the coefficients for non-polynomial functions. + xrange = gsgetr (sx1, GSXMAX) - gsgetr (sx1, GSXMIN) + yrange = gsgetr (sy1, GSYMAX) - gsgetr (sy1, GSYMIN) + if (gsgeti (sx1, GSTYPE) != GS_POLYNOMIAL) { + Memr[xcoeff+GS_SAVECOEFF+1] = Memr[xcoeff+GS_SAVECOEFF+1] * 2. / + xrange + Memr[xcoeff+GS_SAVECOEFF+2] = Memr[xcoeff+GS_SAVECOEFF+2] * 2. / + yrange + } + if (gsgeti (sy1, GSTYPE) != GS_POLYNOMIAL) { + Memr[ycoeff+GS_SAVECOEFF+1] = Memr[ycoeff+GS_SAVECOEFF+1] * 2. / + xrange + Memr[ycoeff+GS_SAVECOEFF+2] = Memr[ycoeff+GS_SAVECOEFF+2] * 2. / + yrange + } + + # Set the shift vector. + ltv[1] = Memr[xcoeff+GS_SAVECOEFF] + ltv[2] = Memr[ycoeff+GS_SAVECOEFF] + + # Set the rotation vector. + ltm[1,1] = Memr[xcoeff+GS_SAVECOEFF+1] + ltm[2,1] = Memr[xcoeff+GS_SAVECOEFF+2] + ltm[1,2] = Memr[ycoeff+GS_SAVECOEFF+1] + ltm[2,2] = Memr[ycoeff+GS_SAVECOEFF+2] + + # Get the sign of the scale vector which is always +ve. + xmin = GT_XMIN(geo) + ymin = GT_YMIN(geo) + if (GT_XMIN(geo) > GT_XMAX(geo)) + xscale = -GT_XSCALE(geo) + else + xscale = GT_XSCALE(geo) + if (GT_YMIN(geo) > GT_YMAX(geo)) + yscale = -GT_YSCALE(geo) + else + yscale = GT_YSCALE(geo) + + # Correct for reference units that are not in pixels. + ltv[1] = ltv[1] + ltm[1,1] * xmin + ltm[2,1] * ymin - ltm[1,1] * + xscale - ltm[2,1] * yscale + ltv[2] = ltv[2] + ltm[1,2] * xmin + ltm[2,2] * ymin - ltm[1,2] * + xscale - ltm[2,2] * yscale + ltm[1,1] = ltm[1,1] * xscale + ltm[2,1] = ltm[2,1] * yscale + ltm[1,2] = ltm[1,2] * xscale + ltm[2,2] = ltm[2,2] * yscale + + call sfree (sp) +end + + +define LTM Memd[ltm+(($2)-1)*pdim+($1)-1] + +# GEO_SWCS -- Update the wcs and write it to the image header. + +procedure geo_swcs (mw, gltm, gltv, ldim) + +pointer mw # the mwcs descriptor +double gltm[ldim,ldim] # the input cd matrix from geotran +double gltv[ldim] # the input shift vector from geotran +int ldim # number of logical dimensions + +int axes[IM_MAXDIM], naxes, pdim, nelem, axmap, ax1, ax2 +pointer sp, ltm, ltv_1, ltv_2 +int mw_stati() + +begin + # Convert axis bitflags to the axis lists. + if (ldim == 1) { + call mw_gaxlist (mw, 01B, axes, naxes) + if (naxes < 1) + return + } else { + call mw_gaxlist (mw, 03B, axes, naxes) + if (naxes < 2) + return + } + + # Initialize the parameters. + pdim = mw_stati (mw, MW_NDIM) + nelem = pdim * pdim + axmap = mw_stati (mw, MW_USEAXMAP) + call mw_seti (mw, MW_USEAXMAP, NO) + + # Allocate working space. + call smark (sp) + call salloc (ltm, nelem, TY_DOUBLE) + call salloc (ltv_1, pdim, TY_DOUBLE) + call salloc (ltv_2, pdim, TY_DOUBLE) + + # Initialize the vectors and matrices. + call mw_mkidmd (Memd[ltm], pdim) + call aclrd (Memd[ltv_1], pdim) + call aclrd (Memd[ltv_2], pdim) + + # Enter the linear operation. + ax1 = axes[1] + Memd[ltv_2+ax1-1] = gltv[1] + LTM(ax1,ax1) = gltm[1,1] + if (ldim == 2) { + ax2 = axes[2] + Memd[ltv_2+ax2-1] = gltv[2] + LTM(ax2,ax1) = gltm[2,1] + LTM(ax1,ax2) = gltm[1,2] + LTM(ax2,ax2) = gltm[2,2] + } + + # Perform the translation. + call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim) + + call sfree (sp) + call mw_seti (mw, MW_USEAXMAP, axmap) +end diff --git a/pkg/images/immatch/src/geometry/t_geoxytran.x b/pkg/images/immatch/src/geometry/t_geoxytran.x new file mode 100644 index 00000000..c99b9a0c --- /dev/null +++ b/pkg/images/immatch/src/geometry/t_geoxytran.x @@ -0,0 +1,343 @@ +include +include +include + +define MAX_FIELDS 100 # Maximum number of fields in list +define TABSIZE 8 # Spacing of tab stops + +# Define the permitted computation types +define GEO_REAL 1 # Computation type is real +define GEO_DOUBLE 2 # Computation type is double + +# T_GEOXYTRAN -- Transform a list of x and y coordinates using the geometric +# transformation operations computed by the GEOMAP task. + +procedure t_geoxytran() + +int inlist, outlist, reclist, calctype, geometry, dir, xcolumn, ycolumn +int min_sigdigits, infd, outfd +pointer sp, in_fname, out_fname, record, xformat, yformat, str, dt +pointer sx1, sy1, sx2, sy2 +int clgwrd(), clgeti(), open() +bool streq() +int fntopnb(), fntlenb(), fntgfnb(), imtopenp(), imtlen(), imtgetim() +pointer dtmap() + +begin + # Allocate memory for transformation parameters structure + call smark (sp) + call salloc (in_fname, SZ_FNAME, TY_CHAR) + call salloc (out_fname, SZ_FNAME, TY_CHAR) + call salloc (record, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Open the input and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDIN", Memc[str], SZ_FNAME) + inlist = fntopnb(Memc[str], NO) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + outlist = fntopnb (Memc[str], NO) + call clgstr ("database", Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + dt = dtmap (Memc[str], READ_ONLY) + reclist = imtopenp ("transforms") + } else { + dt = NULL + reclist = NULL + } + + # Test the input and out file and record lists for validity. + if (fntlenb(inlist) <= 0) + call error (0, "The input file list is empty") + if (fntlenb(outlist) <= 0) + call error (0, "The output file list is empty") + if (fntlenb(outlist) > 1 && fntlenb(outlist) != fntlenb(inlist)) + call error (0, + "Input and output file lists are not the same length") + if (dt != NULL && reclist != NULL) { + if (imtlen (reclist) > 1 && imtlen (reclist) != fntlenb (inlist)) + call error (0, + "Input file and record lists are not the same length.") + } + + # Get geometry and transformation direction. + geometry = clgwrd ("geometry", Memc[str], SZ_LINE, + ",linear,distortion,geometric,") + dir = clgwrd ("direction", Memc[str], SZ_LINE, + ",forward,backward,") + + # Get field numbers from cl + if (dir == 1) + calctype = clgwrd ("calctype", Memc[str], SZ_LINE, + ",real,double,") + else + calctype = GEO_DOUBLE + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get the output file name. + if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) == EOF) + call strcpy ("STDOUT", Memc[out_fname], SZ_FNAME) + outfd = open (Memc[out_fname], NEW_FILE, TEXT_FILE) + if (streq (Memc[out_fname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + + # Get the record name. + if (reclist == NULL) + Memc[record] = EOS + else if (imtgetim (reclist, Memc[record], SZ_FNAME) == EOF) + Memc[record] = EOS + + # Call procedure to get parameters and fill structure. + sx1 = NULL; sy1 = NULL; sx2 = NULL; sy2 = NULL + call geo_init_transform (dt, Memc[record], calctype, geometry, + sx1, sy1, sx2, sy2) + + # While input list is not depleted, open file and transform list. + while (fntgfnb (inlist, Memc[in_fname], SZ_FNAME) != EOF) { + + infd = open (Memc[in_fname], READ_ONLY, TEXT_FILE) + + # Transform the coordinates. + call geo_transform_file (infd, outfd, xcolumn, ycolumn, dir, + calctype, Memc[xformat], Memc[yformat], min_sigdigits, + sx1, sy1, sx2, sy2) + + # Do not get a new output file name if there is not output + # file list or if only one output file was specified. + # Otherwise fetch the new name. + if (fntlenb(outlist) > 1) { + call close (outfd) + if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) != EOF) + outfd = open (Memc[out_fname], NEW_FILE, TEXT_FILE) + if (streq (Memc[out_fname], "STDOUT") || outfd == STDOUT) + call fseti (outfd, F_FLUSHNL, YES) + } + + call close (infd) + + # Do not reset the transformation if there is no record list + # or only one record is specified. Otherwise fetch the next + # record name. + if (reclist != NULL && imtlen (reclist) > 1) { + if (imtgetim (reclist, Memc[record], SZ_FNAME) != EOF) { + call geo_free_transform (calctype, sx1, sy1, sx2, sy2) + call geo_init_transform (dt, Memc[record], calctype, + geometry, sx1, sy1, sx2, sy2) + } + } + } + + # Free the surface descriptors. + call geo_free_transform (calctype, sx1, sy1, sx2, sy2) + + # Close up file and record templates. + if (dt != NULL) + call dtunmap (dt) + call close (outfd) + call fntclsb (inlist) + call fntclsb (outlist) + if (reclist != NULL) + call imtclose (reclist) + call sfree (sp) +end + + +# GEO_INIT_TRANSFORM -- gets parameter values relevant to the +# transformation from the cl. List entries will be transformed +# in procedure rg_transform. + +procedure geo_init_transform (dt, record, calctype, geometry, sx1, sy1, + sx2, sy2) + +pointer dt #I pointer to database file produced by geomap +char record[ARB] #I the name of the database record +int calctype #I the computation data type +int geometry #I the type of geometry to be computed +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +begin + if (dt == NULL) { + + if (calctype == GEO_REAL) + call geo_linitr (sx1, sy1, sx2, sy2) + else + call geo_linitd (sx1, sy1, sx2, sy2) + + } else { + + if (calctype == GEO_REAL) + call geo_sinitr (dt, record, geometry, sx1, sy1, + sx2, sy2) + else + call geo_sinitd (dt, record, geometry, sx1, sy1, + sx2, sy2) + } +end + + +# GEO_FREE_TRANSFORM -- Free the previously defined transformation + +procedure geo_free_transform (calctype, sx1, sy1, sx2, sy2) + +int calctype #I the computation data type +pointer sx1, sy1 #O pointers to the linear x and y surfaces +pointer sx2, sy2 #O pointers to the x and y distortion surfaces + +begin + if (calctype == GEO_REAL) + call geo_sfreer (sx1, sy1, sx2, sy2) + else + call geo_sfreed (sx1, sy1, sx2, sy2) +end + + +# GEO_TRANSFORM_FILE -- This procedure is called once for each file +# in the input list. For each line in the input file that isn't +# blank or comment, the line is transformed. Blank and comment +# lines are output unaltered. + +procedure geo_transform_file (infd, outfd, xfield, yfield, dir, calctype, + xformat, yformat, min_sigdigits, sx1, sy1, sx2, sy2) + +int infd #I the input file descriptor +int outfd #I the output file descriptor +int xfield #I the x column number +int yfield #I the y column number +int dir #I transform direction +int calctype #I the computation type +char xformat[ARB] #I output format of the x coordinate +char yformat[ARB] #I output format of the y coordinate +int min_sigdigits #I the minimum number of digits to be output +pointer sx1, sy1 #I pointers to the linear x and y surfaces +pointer sx2, sy2 #I pointers to the x and y distortion surfaces + +double xd, yd, xtd, ytd +int max_fields, nline, nfields, nchars, nsdig_x, nsdig_y, offset +real xr, yr, xtr, ytr +pointer sp, inbuf, linebuf, field_pos, outbuf, ip +int getline(), li_get_numr(), li_get_numd() + +int nsx, nsy +double der[8], xmin, xmax, ymin, ymax, tol +pointer sx[2], sy[2] +double dgsgetd() + +#double x, y, xt, yt + +begin + call smark (sp) + call salloc (inbuf, SZ_LINE, TY_CHAR) + call salloc (linebuf, SZ_LINE, TY_CHAR) + call salloc (field_pos, MAX_FIELDS, TY_INT) + call salloc (outbuf, SZ_LINE, TY_CHAR) + + max_fields = MAX_FIELDS + + # Initialize for backward transform. + if (dir == 2) { + sx[1] = sx1; sy[1] = sy1; sx[2] = sx2; sy[2] = sy2 + nsx = 2; nsy = 2 + if (sx2 == NULL) + nsx = 1 + if (sy2 == NULL) + nsy = 1 + xmin = dgsgetd (sx1, GSXMIN) + xmax = dgsgetd (sx1, GSXMAX) + ymin = dgsgetd (sx1, GSYMIN) + ymax = dgsgetd (sx1, GSYMAX) + tol = abs (xmax - xmin) / 1E10 + xd = (xmin + xmax) / 2 + yd = (ymin + ymax) / 2 + call tr_init (sx, nsx, sy, nsy, xd, yd, der) + } + + for (nline=1; getline (infd, Memc[inbuf]) != EOF; nline = nline + 1) { + for (ip=inbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#') { + # Pass comment lines on to the output unchanged. + call putline (outfd, Memc[inbuf]) + next + } else if (Memc[ip] == '\n' || Memc[ip] == EOS) { + # Blank lines too. + call putline (outfd, Memc[inbuf]) + next + } + + # Expand tabs into blanks, determine field offsets. + call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE) + call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields, + nfields) + + if (xfield > nfields || yfield > nfields) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Not enough fields in file %s line %d\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+xfield-1] + if (calctype == GEO_REAL) + nchars = li_get_numr (Memc[linebuf+offset-1], xr, nsdig_x) + else + nchars = li_get_numd (Memc[linebuf+offset-1], xd, nsdig_x) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad x value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + offset = Memi[field_pos+yfield-1] + if (calctype == GEO_REAL) + nchars = li_get_numr (Memc[linebuf+offset-1], yr, nsdig_y) + else + nchars = li_get_numd (Memc[linebuf+offset-1], yd, nsdig_y) + if (nchars == 0) { + call fstats (infd, F_FILENAME, Memc[outbuf], SZ_LINE) + call eprintf ("Bad y value in file '%s' at line %d:\n") + call pargstr (Memc[outbuf]) + call pargi (nline) + call putline (outfd, Memc[linebuf]) + next + } + + if (calctype == GEO_REAL) { + call geo_do_transformr (xr, yr, xtr, ytr, + sx1, sy1, sx2, sy2) + call li_pack_liner (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtr, ytr, + xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) + + } else { + if (dir == 1) + call geo_do_transformd (xd, yd, xtd, ytd, + sx1, sy1, sx2, sy2) + else + call tr_invert (sx, nsx, sy, nsy, xd, yd, xtd, ytd, + der, xmin, xmax, ymin, ymax, tol) + call li_pack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE, + Memi[field_pos], nfields, xfield, yfield, xtd, ytd, + xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) + } + + call putline (outfd, Memc[outbuf]) + } + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/geometry/trinvert.x b/pkg/images/immatch/src/geometry/trinvert.x new file mode 100644 index 00000000..5f75cdc2 --- /dev/null +++ b/pkg/images/immatch/src/geometry/trinvert.x @@ -0,0 +1,163 @@ +# The code here is taken from t_transform.x in the longslit package. The +# changes are to use a sum instead of an average when multiple surfaces +# are given and not to use the xgs interface. Also the convergence +# tolerance is user specified since in this application the units might +# not be pixels. + + +define MAX_ITERATE 20 +define ERROR 0.05 +define FUDGE 0.5 + +# TR_INVERT -- Given user coordinate surfaces U(X,Y) and V(X,Y) +# (if none use one-to-one mapping and if more than one sum) +# corresponding to a given U and V and also the various partial +# derivatives. This is done using a gradient following interative +# method based on evaluating the partial derivative at each point +# and solving the linear Taylor expansions simultaneously. The last +# point sampled is used as the starting point. Thus, if the +# input U and V progress smoothly then the number of iterations +# can be small. The output is returned in x and y and in the derivative array +# DER. A point outside of the surfaces is returned as the nearest +# point at the edge of the surfaces in the DER array. + +procedure tr_invert (usf, nusf, vsf, nvsf, u, v, x, y, der, + xmin, xmax, ymin, ymax, tol) + +pointer usf[ARB], vsf[ARB] # User coordinate surfaces U(X,Y) and V(X,Y) +int nusf, nvsf # Number of surfaces for each coordinate +double u, v # Input U and V to determine X and Y +double x, y # Output X and Y +double der[8] # Last result as input, new result as output + # 1=X, 2=Y, 3=U, 4=DUDX, 5=DUDY, 6=V, + # 7=DVDX, 8=DVDY +double xmin, xmax, ymin, ymax # Limits of coordinate surfaces. +double tol # Tolerance + +int i, j, nedge +double fudge, du, dv, dx, dy, tmp[3] + +begin + # Use the last result as the starting point for the next position. + # If this is near the desired value then the interation will converge + # quickly. Allow a iteration to go off the surface twice. + # Quit when DX and DY are within tol. + + nedge = 0 + do i = 1, MAX_ITERATE { + du = u - der[3] + dv = v - der[6] + dx = (der[8] * du - der[5] * dv) / + (der[8] * der[4] - der[5] * der[7]) + dy = (dv - der[7] * dx) / der[8] + fudge = 1 - FUDGE / i + x = der[1] + fudge * dx + y = der[2] + fudge * dy + der[1] = max (xmin, min (xmax, x)) + der[2] = max (ymin, min (ymax, y)) + if ((abs (dx) < tol) && (abs (dy) < tol)) + break + + if (nusf == 0) + der[3] = der[1] + else if (nusf == 1) { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call dgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + } + + if (nvsf == 0) + der[6] = der[2] + else if (nvsf == 1) { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call dgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + } + } +end + + +# TR_INIT -- Since the inversion iteration always begins from the last +# point we need to initialize before the first call to TR_INVERT. + +procedure tr_init (usf, nusf, vsf, nvsf, x, y, der) + +pointer usf[ARB], vsf[ARB] # User coordinate surfaces +int nusf, nvsf # Number of surfaces for each coordinate +double x, y # Starting X and Y +double der[8] # Inversion data + +int j +double tmp[3] + +begin + der[1] = x + der[2] = y + if (nusf == 0) { + der[3] = der[1] + der[4] = 1. + der[5] = 0. + } else if (nusf == 1) { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + } else { + call dgsder (usf[1], der[1], der[2], der[3], 1, 0, 0) + call dgsder (usf[1], der[1], der[2], der[4], 1, 1, 0) + call dgsder (usf[1], der[1], der[2], der[5], 1, 0, 1) + do j = 2, nusf { + call dgsder (usf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (usf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (usf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[3] = der[3] + tmp[1] + der[4] = der[4] + tmp[2] + der[5] = der[5] + tmp[3] + } + } + + if (nvsf == 0) { + der[6] = der[2] + der[7] = 0. + der[8] = 1. + } else if (nvsf == 1) { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + } else { + call dgsder (vsf[1], der[1], der[2], der[6], 1, 0, 0) + call dgsder (vsf[1], der[1], der[2], der[7], 1, 1, 0) + call dgsder (vsf[1], der[1], der[2], der[8], 1, 0, 1) + do j = 2, nvsf { + call dgsder (vsf[j], der[1], der[2], tmp[1], 1, 0, 0) + call dgsder (vsf[j], der[1], der[2], tmp[2], 1, 1, 0) + call dgsder (vsf[j], der[1], der[2], tmp[3], 1, 0, 1) + der[6] = der[6] + tmp[1] + der[7] = der[7] + tmp[2] + der[8] = der[8] + tmp[3] + } + } +end diff --git a/pkg/images/immatch/src/imcombine/imcombine.par b/pkg/images/immatch/src/imcombine/imcombine.par new file mode 100644 index 00000000..ead908e4 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/imcombine.par @@ -0,0 +1,43 @@ +# IMCOMBINE -- Image combine parameters + +input,s,a,,,,List of images to combine +output,s,a,,,,List of output images +headers,s,h,"",,,List of header files (optional) +bpmasks,s,h,"",,,List of bad pixel masks (optional) +rejmasks,s,h,"",,,List of rejection masks (optional) +nrejmasks,s,h,"",,,List of number rejected masks (optional) +expmasks,s,h,"",,,List of exposure masks (optional) +sigmas,s,h,"",,,List of sigma images (optional) +imcmb,s,h,"$I",,,Keyword for IMCMB keywords +logfile,s,h,"STDOUT",,,"Log file +" +combine,s,h,"average","average|median|lmedian|sum|quadrature|nmodel",,Type of combine operation +reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection +project,b,h,no,,,Project highest dimension of input images? +outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype +outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) +offsets,f,h,"none",,,Input image offsets +masktype,s,h,"none","",,Mask type +maskvalue,s,h,"0",,,Mask value +blank,r,h,0.,,,"Value if there are no pixels +" +scale,s,h,"none",,,Image scaling +zero,s,h,"none",,,Image zero point offset +weight,s,h,"none",,,Image weights +statsec,s,h,"",,,Image section for computing statistics +expname,s,h,"",,,"Image header exposure time keyword +" +lthreshold,r,h,INDEF,,,Lower threshold +hthreshold,r,h,INDEF,,,Upper threshold +nlow,i,h,1,0,,minmax: Number of low pixels to reject +nhigh,i,h,1,0,,minmax: Number of high pixels to reject +nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) +mclip,b,h,yes,,,Use median in sigma clipping algorithms? +lsigma,r,h,3.,0.,,Lower sigma clipping factor +hsigma,r,h,3.,0.,,Upper sigma clipping factor +rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) +gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) +snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) +sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections +pclip,r,h,-0.5,,,pclip: Percentile clipping parameter +grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection diff --git a/pkg/images/immatch/src/imcombine/mkpkg b/pkg/images/immatch/src/imcombine/mkpkg new file mode 100644 index 00000000..456232e8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/mkpkg @@ -0,0 +1,20 @@ +# Make the IMCOMBINE Task. + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +standalone: + $set LIBS1 = "src/libimc.a -lxtools -lcurfit -lsurfit -lgsurfit" + $set LIBS2 = "-liminterp -lnlfit -lslalib -lncar -lgks" + $update libimc.a@src + $update libpkg.a + $omake x_imcombine.x + $link x_imcombine.o libpkg.a $(LIBS1) $(LIBS2) -o xx_imcombine.e + ; + +libpkg.a: + t_imcombine.x src/icombine.com src/icombine.h \ + + ; diff --git a/pkg/images/immatch/src/imcombine/src/Revisions b/pkg/images/immatch/src/imcombine/src/Revisions new file mode 100644 index 00000000..469f9e5c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/Revisions @@ -0,0 +1,36 @@ +.help revisions Jul04 imcombine/src +.nf + +This directory contains generic code used in various tasks that combine +images. + +======= +V2.13 +======= + +icgdata.gx + Fixed a problem where 3-D images were closing an image in the case + of many bands leading to a slow execution (10/20/06, Valdes) + +======= +V2.12.3 +======= + +icmask.x +iclog.x +icombine.h + As a special unadvertised feature the "maskvalue" parameter may be + specified with a leading '<' or '>'. Ultimately a full expression + should be added and documented. (7/26/04, Valdes) + +icmask.x + Added a feature to allow masks specified without a path to be found + either in the current directory or the directory with the image. This + is useful when images to be combined are distributed across multiple + directories. (7/16/04, Valdes) + +======== +V2.12.2a +======== + +.endhelp diff --git a/pkg/images/immatch/src/imcombine/src/generic/icaclip.x b/pkg/images/immatch/src/imcombine/src/generic/icaclip.x new file mode 100644 index 00000000..8fb89b1b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icaclip.x @@ -0,0 +1,2207 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number of images for this algorithm + + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclips (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mems[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Mems[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mems[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclips (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, sig, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Mems[d[1]+k] + else { + low = Mems[d[1]+k] + high = Mems[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Mems[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Mems[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Mems[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Mems[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = sig * sqrt (max (one, med)) + for (; nl <= nh; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mems[d[n3-1]+k] + high = Mems[d[n3]+k] + med = (low + high) / 2. + } else + med = Mems[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipi (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memi[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memi[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memi[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipi (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, sig, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memi[d[1]+k] + else { + low = Memi[d[1]+k] + high = Memi[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memi[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memi[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memi[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memi[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = sig * sqrt (max (one, med)) + for (; nl <= nh; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memi[d[n3-1]+k] + high = Memi[d[n3]+k] + med = (low + high) / 2. + } else + med = Memi[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipr (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memr[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memr[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memr[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipr (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +real med, low, high, sig, r, s, s1, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memr[d[1]+k] + else { + low = Memr[d[1]+k] + high = Memr[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memr[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memr[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memr[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memr[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = sig * sqrt (max (one, med)) + for (; nl <= nh; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memr[d[n3-1]+k] + high = Memr[d[n3]+k] + med = (low + high) / 2. + } else + med = Memr[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclipd (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, s1, r, one +data one /1.0D0/ +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memd[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Memd[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Memd[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclipd (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +double med, low, high, sig, r, s, s1, one +data one /1.0D0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Memd[d[1]+k] + else { + low = Memd[d[1]+k] + high = Memd[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Memd[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Memd[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Memd[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Memd[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = sig * sqrt (max (one, med)) + for (; nl <= nh; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Memd[d[n3-1]+k] + high = Memd[d[n3]+k] + med = (low + high) / 2. + } else + med = Memd[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icaverage.x b/pkg/images/immatch/src/imcombine/src/generic/icaverage.x new file mode 100644 index 00000000..7167d301 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icaverage.x @@ -0,0 +1,424 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averages (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mems[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mems[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Mems[d[1]+k] + do j = 2, n[i] + sum = sum + Mems[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mems[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Mems[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averagei (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memi[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memi[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memi[d[1]+k] + do j = 2, n[i] + sum = sum + Memi[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memi[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memi[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averager (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memr[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memr[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memr[d[1]+k] + do j = 2, n[i] + sum = sum + Memr[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memr[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memr[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_averaged (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real sumwt, wt +double sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memd[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Memd[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Memd[d[1]+k] + do j = 2, n[i] + sum = sum + Memd[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Memd[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Memd[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/iccclip.x b/pkg/images/immatch/src/imcombine/src/generic/iccclip.x new file mode 100644 index 00000000..cf60c779 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/iccclip.x @@ -0,0 +1,1791 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 2 # Mininum number of images for algorithm + + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclips (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Mems[d[1]+k] + sum = sum + Mems[d[2]+k] + a = sum / 2 + } else { + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclips (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Mems[d[n3-1]+k] + med = (med + Mems[d[n3]+k]) / 2. + } else + med = Mems[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= nh; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipi (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memi[d[1]+k] + sum = sum + Memi[d[2]+k] + a = sum / 2 + } else { + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipi (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memi[d[n3-1]+k] + med = (med + Memi[d[n3]+k]) / 2. + } else + med = Memi[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= nh; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipr (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memr[d[1]+k] + sum = sum + Memr[d[2]+k] + a = sum / 2 + } else { + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipr (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +real med, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memr[d[n3-1]+k] + med = (med + Memr[d[n3]+k]) / 2. + } else + med = Memr[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= nh; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclipd (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, r, zero +data zero /0.0D0/ +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Memd[d[1]+k] + sum = sum + Memd[d[2]+k] + a = sum / 2 + } else { + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclipd (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +double med, zero +data zero /0.0D0/ + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Memd[d[n3-1]+k] + med = (med + Memd[d[n3]+k]) / 2. + } else + med = Memd[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= nh; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icgdata.x b/pkg/images/immatch/src/imcombine/src/generic/icgdata.x new file mode 100644 index 00000000..774de63c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icgdata.x @@ -0,0 +1,1531 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" + + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +short temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnls() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnls + +short max_pixel +data max_pixel/MAX_SHORT/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnls (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnls (in[i], i, buf, v2, v1[2]) + call amovs (Mems[buf+k-1], Mems[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Mems[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Mems[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages { + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + } + do i = nused+1, nimages + d[i] = NULL + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mems[d[k]+j-1] + Mems[d[k]+j-1] = Mems[dp] + Mems[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mems[d[k]+j-1] + Mems[d[k]+j-1] = Mems[dp] + Mems[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_SHORT) + if (keepids) { + call malloc (ip, nused, TY_INT) + call ic_2sorts (d, Mems[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sorts (d, Mems[dp], n, npts) + call mfree (dp, TY_SHORT) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Mems[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Mems[d[k]+j-1] = Mems[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Mems[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Mems[d[k]+j-1] = Mems[dp] + } + } + } + } + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +int temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnli() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnli + +int max_pixel +data max_pixel/MAX_INT/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnli (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnli (in[i], i, buf, v2, v1[2]) + call amovi (Memi[buf+k-1], Memi[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memi[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memi[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + Memi[dp] = Memi[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages { + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + } + do i = nused+1, nimages + d[i] = NULL + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memi[d[k]+j-1] + Memi[d[k]+j-1] = Memi[dp] + Memi[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memi[d[k]+j-1] + Memi[d[k]+j-1] = Memi[dp] + Memi[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_INT) + if (keepids) { + call malloc (ip, nused, TY_INT) + call ic_2sorti (d, Memi[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sorti (d, Memi[dp], n, npts) + call mfree (dp, TY_INT) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memi[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memi[d[k]+j-1] = Memi[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memi[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memi[d[k]+j-1] = Memi[dp] + } + } + } + } + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +real temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnlr() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnlr + +real max_pixel +data max_pixel/MAX_REAL/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnlr (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnlr (in[i], i, buf, v2, v1[2]) + call amovr (Memr[buf+k-1], Memr[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memr[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memr[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages { + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + } + do i = nused+1, nimages + d[i] = NULL + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memr[d[k]+j-1] + Memr[d[k]+j-1] = Memr[dp] + Memr[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memr[d[k]+j-1] + Memr[d[k]+j-1] = Memr[dp] + Memr[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_REAL) + if (keepids) { + call malloc (ip, nused, TY_INT) + call ic_2sortr (d, Memr[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sortr (d, Memr[dp], n, npts) + call mfree (dp, TY_REAL) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memr[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memr[d[k]+j-1] = Memr[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memr[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memr[d[k]+j-1] = Memr[dp] + } + } + } + } + } +end + +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +double temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnld() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnld + +double max_pixel +data max_pixel/MAX_DOUBLE/ + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnld (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnld (in[i], i, buf, v2, v1[2]) + call amovd (Memd[buf+k-1], Memd[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Memd[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Memd[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + Memd[dp] = Memd[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages { + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + } + do i = nused+1, nimages + d[i] = NULL + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memd[d[k]+j-1] + Memd[d[k]+j-1] = Memd[dp] + Memd[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Memd[d[k]+j-1] + Memd[d[k]+j-1] = Memd[dp] + Memd[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_DOUBLE) + if (keepids) { + call malloc (ip, nused, TY_INT) + call ic_2sortd (d, Memd[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sortd (d, Memd[dp], n, npts) + call mfree (dp, TY_DOUBLE) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Memd[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Memd[d[k]+j-1] = Memd[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Memd[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Memd[d[k]+j-1] = Memd[dp] + } + } + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icgrow.x b/pkg/images/immatch/src/imcombine/src/generic/icgrow.x new file mode 100644 index 00000000..1ccb7885 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icgrow.x @@ -0,0 +1,263 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" + +# IC_GROW -- Mark neigbors of rejected pixels. +# The rejected pixels (original plus grown) are saved in pixel masks. + +procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) + +pointer out # Output image pointer +long v[ARB] # Output vector +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[npts,nimages] # Working buffer +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() +real grow2, i2 +pointer mp, pm, pm_newmask() +errchk pm_newmask() + +include "../icombine.com" + +begin + if (dflag == D_NONE || grow == 0.) + return + + line = v[2] + nl = IM_LEN(out,2) + rop = or (PIX_SRC, PIX_DST) + + igrow = grow + grow2 = grow**2 + do l = 0, igrow { + i2 = grow2 - l * l + call aclri (buf, npts*nimages) + nset = 0 + do j = 1, npts { + do k = n[j]+1, nimages { + mp = Memi[m[k]+j-1] + if (mp == 0) + next + do i = 0, igrow { + if (i**2 > i2) + next + if (j > i) + buf[j-i,mp] = 1 + if (j+i <= npts) + buf[j+i,mp] = 1 + nset = nset + 1 + } + } + } + if (nset == 0) + return + + if (pms == NULL) { + call malloc (pms, nimages, TY_POINTER) + do i = 1, nimages + Memi[pms+i-1] = pm_newmask (out, 1) + ncompress = 0 + } + do i = 1, nimages { + pm = Memi[pms+i-1] + v[2] = line - l + if (v[2] > 0) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +end + + + +# IC_GROW$T -- Reject pixels. + +procedure ic_grows (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Mems[d[j]+i-1] = Mems[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growi (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memi[d[j]+i-1] = Memi[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growr (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memr[d[j]+i-1] = Memr[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end + +# IC_GROW$T -- Reject pixels. + +procedure ic_growd (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Memd[d[j]+i-1] = Memd[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end diff --git a/pkg/images/immatch/src/imcombine/src/generic/icmedian.x b/pkg/images/immatch/src/imcombine/src/generic/icmedian.x new file mode 100644 index 00000000..c482454b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icmedian.x @@ -0,0 +1,753 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_MEDIAN -- Median of lines + +procedure ic_medians (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +short temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Mems[d[j1]+k] + val2 = Mems[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mems[d[j1]+k] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + j2 = n1 / 2 + val1 = Mems[d[j1]+k] + val2 = Mems[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mems[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + return + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mems[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mems[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Mems[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Mems[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mems[d[lo1]+k] + Mems[d[lo1]+k] = Mems[d[up1]+k] + Mems[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mems[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Mems[d[1]+k] + val2 = Mems[d[2]+k] + val3 = Mems[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mems[d[1]+k] + val2 = Mems[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mems[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_mediani (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +int temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memi[d[j1]+k] + val2 = Memi[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memi[d[j1]+k] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + j2 = n1 / 2 + val1 = Memi[d[j1]+k] + val2 = Memi[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memi[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + return + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memi[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memi[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memi[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memi[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memi[d[lo1]+k] + Memi[d[lo1]+k] = Memi[d[up1]+k] + Memi[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memi[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memi[d[1]+k] + val2 = Memi[d[2]+k] + val3 = Memi[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memi[d[1]+k] + val2 = Memi[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memi[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_medianr (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +real median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +real val1, val2, val3 +real temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memr[d[j1]+k] + val2 = Memr[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memr[d[j1]+k] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + j2 = n1 / 2 + val1 = Memr[d[j1]+k] + val2 = Memr[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memr[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + return + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memr[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memr[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memr[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memr[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memr[d[lo1]+k] + Memr[d[lo1]+k] = Memr[d[up1]+k] + Memr[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memr[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memr[d[1]+k] + val2 = Memr[d[2]+k] + val3 = Memr[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memr[d[1]+k] + val2 = Memr[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memr[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_mediand (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +double median[npts] # Median + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +double val1, val2, val3 +double temp, wtemp + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Memd[d[j1]+k] + val2 = Memd[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memd[d[j1]+k] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + j2 = n1 / 2 + val1 = Memd[d[j1]+k] + val2 = Memd[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Memd[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + return + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Memd[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Memd[d[j]+k]; lo1 = lo; up1 = up + + repeat { + while (Memd[d[lo1]+k] < temp) + lo1 = lo1 + 1 + while (temp < Memd[d[up1]+k]) + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Memd[d[lo1]+k] + Memd[d[lo1]+k] = Memd[d[up1]+k] + Memd[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Memd[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + val1 = Memd[d[1]+k] + val2 = Memd[d[2]+k] + val3 = Memd[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + + # If 2 points average. + } else if (n1 == 2) { + val1 = Memd[d[1]+k] + val2 = Memd[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Memd[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icmm.x b/pkg/images/immatch/src/imcombine/src/generic/icmm.x new file mode 100644 index 00000000..9c8274c8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icmm.x @@ -0,0 +1,645 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mms (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +short d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = max (0, n[1]) + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = max (0, n[i]) + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Mems[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Mems[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Mems[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mems[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mems[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mems[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Mems[kmax] = d2 + else + Mems[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Mems[kmin] = d1 + else + Mems[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Mems[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Mems[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Mems[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Mems[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Mems[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Mems[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Mems[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Mems[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmi (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +int d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = max (0, n[1]) + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = max (0, n[i]) + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memi[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memi[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memi[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memi[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memi[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memi[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memi[kmax] = d2 + else + Memi[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memi[kmin] = d1 + else + Memi[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memi[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memi[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memi[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memi[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memi[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memi[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memi[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memi[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmr (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +real d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = max (0, n[1]) + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = max (0, n[i]) + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memr[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memr[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memr[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memr[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memr[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memr[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memr[kmax] = d2 + else + Memr[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memr[kmin] = d1 + else + Memr[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memr[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memr[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memr[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memr[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memr[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memr[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memr[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memr[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mmd (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +double d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = max (0, n[1]) + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = max (0, n[i]) + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + d1 = Memd[k] + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + d1 = Memd[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Memd[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Memd[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Memd[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Memd[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Memd[kmax] = d2 + else + Memd[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Memd[kmin] = d1 + else + Memd[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + d1 = Memd[k] + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memd[k] + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Memd[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Memd[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + d1 = Memd[k] + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + d1 = Memd[k] + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Memd[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Memd[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icnmodel.x b/pkg/images/immatch/src/imcombine/src/generic/icnmodel.x new file mode 100644 index 00000000..559cba73 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icnmodel.x @@ -0,0 +1,528 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodels (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Mems[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mems[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Mems[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodeli (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memi[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memi[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memi[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodelr (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum, zero +data zero /0.0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memr[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memr[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memr[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodeld (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +double sum, zero +data zero /0.0D0/ + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Memd[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Memd[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Memd[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icomb.x b/pkg/images/immatch/src/imcombine/src/generic/icomb.x new file mode 100644 index 00000000..3466073b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icomb.x @@ -0,0 +1,2198 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "../icombine.h" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include + + +# ICOMBINE -- Combine images +# +# The memory and open file descriptor limits are checked and an attempt +# to recover is made either by setting the image pixel files to be +# closed after I/O or by notifying the calling program that memory +# ran out and the IMIO buffer size should be reduced. After the checks +# a procedure for the selected combine option is called. +# Because there may be several failure modes when reaching the file +# limits we first assume an error is due to the file limit, except for +# out of memory, and close some pixel files. If the error then repeats +# on accessing the pixels the error is passed back. + + +procedure icombines (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnls() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnls, impl1i, ic_combines +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages { + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + call aclrs (Mems[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + call aclrs (Mems[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnls (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combines (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combines (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_grows, ic_rmasks, ic_emask +errchk ic_gdatas + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclips (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclips (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mms (d, id, n, npts) + case PCLIP: + call ic_pclips (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclips (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclips (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclips (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclips (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quads (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodels (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmas (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grows (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averages (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quads (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodels (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmas (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombinei (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnli() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnli, impl1i, ic_combinei +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages { + call salloc (Memi[dbuf+i-1], npts, TY_INT) + call aclri (Memi[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_INT) + call aclri (Memi[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnli (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combinei (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combinei (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr() +errchk immap, ic_scale, imgetr, ic_grow, ic_growi, ic_rmasks, ic_emask +errchk ic_gdatai + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipi (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclipi (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mmi (d, id, n, npts) + case PCLIP: + call ic_pclipi (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipi (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclipi (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipi (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclipi (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averagei (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quadi (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodeli (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmai (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growi (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averagei (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_mediani (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averagei (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quadi (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodeli (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmai (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombiner (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnlr() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnlr, impl1i, ic_combiner +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages { + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + call aclrr (Memr[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + call aclrr (Memr[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnlr (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combiner (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combiner (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnlr(), imgnlr +errchk immap, ic_scale, imgetr, ic_grow, ic_growr, ic_rmasks, ic_emask +errchk ic_gdatar + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipr (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclipr (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mmr (d, id, n, npts) + case PCLIP: + call ic_pclipr (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipr (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclipr (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipr (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclipr (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quadr (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodelr (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmar (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growr (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_averager (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quadr (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodelr (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigmar (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + +procedure icombined (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnld() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnld, impl1i, ic_combined +pointer impl1d() +errchk impl1d + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages { + call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) + call aclrd (Memd[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) + call aclrd (Memd[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + buf = impl1d (out[1]) + call aclrd (Memd[buf], npts) + if (out[3] != NULL) { + buf = impl1d (out[3]) + call aclrd (Memd[buf], npts) + } + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnld (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combined (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combined (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +pointer impnld(), imgnld +errchk immap, ic_scale, imgetr, ic_grow, ic_growd, ic_rmasks, ic_emask +errchk ic_gdatad + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + while (impnld (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclipd (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memd[outdata]) + else + call ic_accdclipd (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memd[outdata]) + case MINMAX: + call ic_mmd (d, id, n, npts) + case PCLIP: + call ic_pclipd (d, id, n, nimages, npts, Memd[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclipd (d, id, n, scales, zeros, nimages, npts, + Memd[outdata]) + else + call ic_asigclipd (d, id, n, scales, zeros, nimages, npts, + Memd[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclipd (d, id, n, scales, zeros, nimages, + npts, Memd[outdata]) + else + call ic_aavsigclipd (d, id, n, scales, zeros, nimages, + npts, Memd[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averaged (d, id, n, wts, nimages, npts, + YES, YES, Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, YES, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, nimages, npts, + YES, NO, Memd[outdata]) + case QUAD: + call ic_quadd (d, id, n, wts, nimages, npts, + YES, YES, Memd[outdata]) + case NMODEL: + call ic_nmodeld (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Memd[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnld (out[3], buf, Meml[v1]) + call ic_sigmad (d, id, n, wts, npts, Memd[outdata], + Memd[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + while (impnld (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_growd (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnld (out[1], buf, Meml[v1]) == EOF) + ; + call amovd (Memd[buf], Memd[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_averaged (d, id, n, wts, nimages, npts, + NO, YES, Memd[outdata]) + case MEDIAN: + call ic_mediand (d, n, npts, NO, Memd[outdata]) + case SUM: + call ic_averaged (d, id, n, wts, nimages, npts, + NO, NO, Memd[outdata]) + case QUAD: + call ic_quadd (d, id, n, wts, nimages, npts, + NO, YES, Memd[outdata]) + case NMODEL: + call ic_nmodeld (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memd[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnld (out[3], buf, Meml[v1]) + call ic_sigmad (d, id, n, wts, npts, Memd[outdata], + Memd[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icpclip.x b/pkg/images/immatch/src/imcombine/src/generic/icpclip.x new file mode 100644 index 00000000..3dfe7f48 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icpclip.x @@ -0,0 +1,879 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number for clipping + + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclips (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = max (0, n[1]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Mems[d[n2-1]+j] + med = (med + Mems[d[n2]+j]) / 2. + } else + med = Mems[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Mems[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Mems[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Mems[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Mems[d[n5-1]+j] + med = (med + Mems[d[n5]+j]) / 2. + } else + med = Mems[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+j] = Mems[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+j] = Mems[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipi (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = max (0, n[1]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memi[d[n2-1]+j] + med = (med + Memi[d[n2]+j]) / 2. + } else + med = Memi[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memi[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memi[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memi[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memi[d[n5-1]+j] + med = (med + Memi[d[n5]+j]) / 2. + } else + med = Memi[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+j] = Memi[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+j] = Memi[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipr (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +real med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = max (0, n[1]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memr[d[n2-1]+j] + med = (med + Memr[d[n2]+j]) / 2. + } else + med = Memr[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memr[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memr[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memr[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memr[d[n5-1]+j] + med = (med + Memr[d[n5]+j]) / 2. + } else + med = Memr[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+j] = Memr[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+j] = Memr[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclipd (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +double med + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = max (0, n[1]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Memd[d[n2-1]+j] + med = (med + Memd[d[n2]+j]) / 2. + } else + med = Memd[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Memd[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Memd[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Memd[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Memd[d[n5-1]+j] + med = (med + Memd[d[n5]+j]) / 2. + } else + med = Memd[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+j] = Memd[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+j] = Memd[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icquad.x b/pkg/images/immatch/src/imcombine/src/generic/icquad.x new file mode 100644 index 00000000..4ba5eb14 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icquad.x @@ -0,0 +1,476 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quads (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Mems[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Mems[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Mems[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mems[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Mems[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mems[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mems[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mems[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadi (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memi[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memi[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memi[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memi[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memi[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memi[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memi[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memi[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadr (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +real average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +real sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memr[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memr[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memr[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memr[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memr[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memr[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memr[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memr[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quadd (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +double average[npts] # Average (returned) + +int i, j, k, n1 +real val, wt, sumwt +double sum + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Memd[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Memd[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Memd[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memd[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Memd[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memd[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Memd[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Memd[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icsclip.x b/pkg/images/immatch/src/imcombine/src/generic/icsclip.x new file mode 100644 index 00000000..2f2ac17e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icsclip.x @@ -0,0 +1,1923 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Mininum number of images for algorithm + + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclips (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mems[d[1]+k] + do j = 2, n1 + sum = sum + Mems[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Mems[d[1]+k] + high = Mems[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mems[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mems[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mems[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Mems[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mems[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mems[dp1] + Mems[dp1] = Mems[dp2] + Mems[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mems[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclips (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Mems[d[n3-1]+k] + Mems[d[n3]+k]) / 2. + else + med = Mems[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Mems[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Mems[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Mems[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mems[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mems[d[l]+k] = Mems[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipi (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memi[d[1]+k] + do j = 2, n1 + sum = sum + Memi[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memi[d[1]+k] + high = Memi[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memi[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memi[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memi[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memi[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memi[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memi[dp1] + Memi[dp1] = Memi[dp2] + Memi[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memi[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipi (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memi[d[n3-1]+k] + Memi[d[n3]+k]) / 2. + else + med = Memi[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memi[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memi[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memi[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memi[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memi[d[l]+k] = Memi[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memi[d[l]+k] = Memi[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipr (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +real d1, low, high, sum, a, s, r, one +data one /1.0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memr[d[1]+k] + do j = 2, n1 + sum = sum + Memr[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memr[d[1]+k] + high = Memr[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memr[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memr[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memr[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memr[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memr[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memr[dp1] + Memr[dp1] = Memr[dp2] + Memr[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memr[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipr (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +real median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +real med, one +data one /1.0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memr[d[n3-1]+k] + Memr[d[n3]+k]) / 2. + else + med = Memr[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memr[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memr[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memr[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memr[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memr[d[l]+k] = Memr[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclipd (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double average[npts] # Average + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +double d1, low, high, sum, a, s, r, one +data one /1.0D0/ +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Memd[d[1]+k] + do j = 2, n1 + sum = sum + Memd[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Memd[d[1]+k] + high = Memd[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Memd[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memd[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Memd[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Memd[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Memd[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Memd[dp1] + Memd[dp1] = Memd[dp2] + Memd[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Memd[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclipd (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +double median[npts] # Median + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +double med, one +data one /1.0D0/ + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Memd[d[n3-1]+k] + Memd[d[n3]+k]) / 2. + else + med = Memd[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Memd[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Memd[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Memd[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Memd[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memd[d[l]+k] = Memd[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Memd[d[l]+k] = Memd[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icsigma.x b/pkg/images/immatch/src/imcombine/src/generic/icsigma.x new file mode 100644 index 00000000..b9c9a781 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icsigma.x @@ -0,0 +1,434 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../icombine.h" + + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmas (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mems[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mems[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mems[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mems[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Mems[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mems[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmai (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memi[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memi[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memi[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memi[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memi[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memi[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmar (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +real average[npts] # Average +real sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +real a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memr[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memr[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memr[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memr[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memr[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memr[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigmad (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +double average[npts] # Average +double sigma[npts] # Sigma line (returned) + +int i, j, k, n1 +real wt, sigcor, sumwt +double a, sum + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memd[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memd[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Memd[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Memd[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Memd[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Memd[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/icsort.x b/pkg/images/immatch/src/imcombine/src/generic/icsort.x new file mode 100644 index 00000000..3ec1d27e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icsort.x @@ -0,0 +1,1096 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sorts (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +short b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +short pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Mems[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Mems[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Mems[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sorts (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +short b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +short pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Mems[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Mems[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sorti (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +int b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +int pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memi[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memi[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memi[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sorti (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +int b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +int pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memi[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memi[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sortr (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +real b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +real pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memr[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memr[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memr[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sortr (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +real b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +real pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memr[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memr[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end + +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sortd (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +double b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +double pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Memd[a[i]+l] + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + + # General case + do i = 1, npix + b[i] = Memd[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Memd[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sortd (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +double b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +double pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Memd[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + for (i=i+1; b[i] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (b[j] <= pivot) + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Memd[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end diff --git a/pkg/images/immatch/src/imcombine/src/generic/icstat.x b/pkg/images/immatch/src/imcombine/src/generic/icstat.x new file mode 100644 index 00000000..3a0ed49c --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/icstat.x @@ -0,0 +1,892 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../icombine.h" + +define NMAX 100000 # Maximum number of pixels to sample + + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stats (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnls() + +real asums() +short ic_modes() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_SHORT) + dp = data + while (imgnls (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Mems[lp] + if (a >= lthresh && a <= hthresh) { + Mems[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Mems[dp] = Mems[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Mems[lp] + if (a >= lthresh && a <= hthresh) { + Mems[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Mems[dp] = Mems[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrts (Mems[data], Mems[data], n) + mode = ic_modes (Mems[data], n) + median = Mems[data+n/2-1] + } + if (domean) + mean = asums (Mems[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +short procedure ic_modes (a, n) + +short a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +short mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + zstep = max (1., zstep) + zbin = max (1., zbin) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stati (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnli() + +real asumi() +int ic_modei() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_INT) + dp = data + while (imgnli (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memi[lp] + if (a >= lthresh && a <= hthresh) { + Memi[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memi[dp] = Memi[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memi[lp] + if (a >= lthresh && a <= hthresh) { + Memi[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memi[dp] = Memi[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrti (Memi[data], Memi[data], n) + mode = ic_modei (Memi[data], n) + median = Memi[data+n/2-1] + } + if (domean) + mean = asumi (Memi[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +int procedure ic_modei (a, n) + +int a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +int mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + zstep = max (1., zstep) + zbin = max (1., zbin) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_statr (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnlr() + +real asumr() +real ic_moder() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_REAL) + dp = data + while (imgnlr (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memr[lp] + if (a >= lthresh && a <= hthresh) { + Memr[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memr[dp] = Memr[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memr[lp] + if (a >= lthresh && a <= hthresh) { + Memr[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memr[dp] = Memr[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrtr (Memr[data], Memr[data], n) + mode = ic_moder (Memr[data], n) + median = Memr[data+n/2-1] + } + if (domean) + mean = asumr (Memr[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +real procedure ic_moder (a, n) + +real a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +real mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_statd (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnld() + +double asumd() +double ic_moded() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_DOUBLE) + dp = data + while (imgnld (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Memd[lp] + if (a >= lthresh && a <= hthresh) { + Memd[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Memd[dp] = Memd[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Memd[lp] + if (a >= lthresh && a <= hthresh) { + Memd[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Memd[dp] = Memd[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrtd (Memd[data], Memd[data], n) + mode = ic_moded (Memd[data], n) + median = Memd[data+n/2-1] + } + if (domean) + mean = asumd (Memd[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +double procedure ic_moded (a, n) + +double a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +double mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end + diff --git a/pkg/images/immatch/src/imcombine/src/generic/mkpkg b/pkg/images/immatch/src/imcombine/src/generic/mkpkg new file mode 100644 index 00000000..af2fd0a8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/mkpkg @@ -0,0 +1,27 @@ +# Make IMCOMBINE. + +$checkout libimc.a lib$ +$update libimc.a +$checkin libimc.a lib$ +$exit + +libimc.a: + icaclip.x ../icombine.com ../icombine.h + icaverage.x ../icombine.com ../icombine.h + iccclip.x ../icombine.com ../icombine.h + icgdata.x ../icombine.com ../icombine.h + icgrow.x ../icombine.com ../icombine.h + icmedian.x ../icombine.com ../icombine.h + icmm.x ../icombine.com ../icombine.h + icnmodel.x ../icombine.com ../icombine.h + icomb.x ../icombine.com ../icombine.h \ + + icpclip.x ../icombine.com ../icombine.h + icquad.x ../icombine.com ../icombine.h + icsclip.x ../icombine.com ../icombine.h + icsigma.x ../icombine.com ../icombine.h + icsort.x + icstat.x ../icombine.com ../icombine.h + + xtimmap.x xtimmap.com + ; diff --git a/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com new file mode 100644 index 00000000..57fcb8a0 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.com @@ -0,0 +1,9 @@ +int option +int nopen +int nopenpix +int nalloc +int last_flag +int min_open +int max_openim +pointer ims +common /xtimmapcom/ option, ims, nopen, nopenpix, nalloc, last_flag, min_open, max_openim diff --git a/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x new file mode 100644 index 00000000..fcc53124 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/generic/xtimmap.x @@ -0,0 +1,1207 @@ +include +include +include +include +include + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include + +define VERBOSE false + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +int retry #I Retry counter +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Set maximum number of open images based on retry. + if (retry > 0) + max_openim = min (1024, MAX_OPENIM) / retry + else + max_openim = MAX_OPENIM + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = max_openim + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + max_openim + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_opix imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + if (VERBOSE) { + call eprintf ("%d: imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_opix immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_cpix imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_imunmap imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_MINHDR -- Minimize header assuming keywords will not be accessed. + +procedure xt_minhdr (index) + +int index #I index + +pointer xt +errchk realloc + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) + return + + # Minimize header pointer. + if (VERBOSE) { + call eprintf ("%d: xt_minhdr %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) + if (XT_IM(xt) != NULL) + call realloc (XT_IM(xt), IMU+1, TY_STRUCT) +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnls (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnls(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggss() +errchk open, immap, imgnls, imggss, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnls (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnls (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_SHORT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_SHORT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_SHORT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggss (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovs (Mems[ptr], Mems[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnls (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnli (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnli(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsi() +errchk open, immap, imgnli, imggsi, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnli (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnli (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_INT) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_INT) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_INT + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsi (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovi (Memi[ptr], Memi[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnli (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnlr (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnlr(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsr() +errchk open, immap, imgnlr, imggsr, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnlr (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnlr (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_REAL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_REAL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_REAL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsr (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovr (Memr[ptr], Memr[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnlr (im, buf, v)) +end + +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnld (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnld(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggsd() +errchk open, immap, imgnld, imggsd, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnld (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnld (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_DOUBLE) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_DOUBLE) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_DOUBLE + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggsd (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amovd (Memd[ptr], Memd[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnld (im, buf, v)) +end + diff --git a/pkg/images/immatch/src/imcombine/src/icaclip.gx b/pkg/images/immatch/src/imcombine/src/icaclip.gx new file mode 100644 index 00000000..de3b04d6 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icaclip.gx @@ -0,0 +1,575 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number of images for this algorithm + +$for (sird) +# IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_aavsigclip$t (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, s1, r, one +data one /1.0/ +$else +PIXEL d1, low, high, sum, a, s, s1, r, one +data one /1$f/ +$endif +pointer sp, sums, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (sums, npts, TY_REAL) + call salloc (resid, nimages+1, TY_REAL) + + # Since the unweighted average is computed here possibly skip combining + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Compute the unweighted average with the high and low rejected and + # the poisson scaled average sigma. There must be at least three + # pixels at each point to define the average and contributions to + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + nin = max (0, n[1]) + s = 0. + n2 = 0 + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) + next + + # Unweighted average with the high and low rejected + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mem$t[dp1] + l = Memi[mp1] + s1 = max (one, (a + zeros[l]) / scales[l]) + s = s + (d1 - a) ** 2 / s1 + } + } else { + s1 = max (one, a) + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - a) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the average and sum for later. + average[i] = a + Memr[sums+k] = sum + } + + # Here is the final sigma. + if (n2 > 1) + s = sqrt (s / (n2 - 1)) + + # Reject pixels and compute the final average (if needed). + # There must be at least three pixels at each point for rejection. + # Iteratively scale the mean sigma and reject pixels + # Compact the data and keep track of the image IDs if needed. + + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (2, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + a = average[i] + sum = Memr[sums+k] + + repeat { + n2 = n1 + if (s > 0.) { + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + d1 = Mem$t[dp1] + l = Memi[mp1] + s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + s1 = s * sqrt (max (one, a)) + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s1 + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median +# The average sigma is normalized by the expected poisson sigma. + +procedure ic_mavsigclip$t (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med, low, high, sig, r, s, s1, one +data one /1.0/ +$else +PIXEL med, low, high, sig, r, s, s1, one +data one /1$f/ +$endif + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute the poisson scaled average sigma about the median. + # There must be at least three pixels at each point to define + # the mean sigma. Corrections for differences in the image + # scale factors are selected by the doscale1 flag. + + s = 0. + n2 = 0 + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (n1 < 3) { + if (n1 == 0) + median[i] = blank + else if (n1 == 1) + median[i] = Mem$t[d[1]+k] + else { + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + median[i] = (low + high) / 2. + } + next + } + + # Median + n3 = 1 + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + + # Poisson scaled sigma accumulation + if (doscale1) { + do j = 1, n1 { + l = Memi[m[j]+k] + s1 = max (one, (med + zeros[l]) / scales[l]) + s = s + (Mem$t[d[j]+k] - med) ** 2 / s1 + } + } else { + s1 = max (one, med) + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - med) ** 2 / s1 + } + n2 = n2 + n1 + + # Save the median for later. + median[i] = med + } + + # Here is the final sigma. + if (n2 > 1) + sig = sqrt (s / (n2 - 1)) + else { + call sfree (sp) + return + } + + # Compute individual sigmas and iteratively clip. + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 < max (3, maxkeep+1)) + next + nl = 1 + nh = n1 + med = median[i] + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 >= max (MINCLIP, maxkeep+1) && sig > 0.) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (med - Mem$t[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) + r = (Mem$t[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + s1 = sig * sqrt (max (one, med)) + for (; nl <= nh; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / s1 + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / s1 + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + } else + med = blank + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many are rejected add some back in. + # Pixels with equal residuals are added together. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + + # Recompute median + if (n1 < n2) { + if (n1 > 0) { + n3 = nl + n1 / 2 + if (mod (n1, 2) == 0) { + low = Mem$t[d[n3-1]+k] + high = Mem$t[d[n3]+k] + med = (low + high) / 2. + } else + med = Mem$t[d[n3]+k] + } else + med = blank + } + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icaverage.gx b/pkg/images/immatch/src/imcombine/src/icaverage.gx new file mode 100644 index 00000000..a474bb9d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icaverage.gx @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_AVERAGE -- Compute the average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_average$t (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +real sumwt, wt +$if (datatype == sil) +real sum +$else +PIXEL sum +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mem$t[d[1]+k] * wt + do j = 2, n[i] { + wt = wts[Memi[m[j]+k]] + sum = sum + Mem$t[d[j]+k] * wt + } + average[i] = sum + } + } else { + do i = 1, npts { + k = i - 1 + sum = Mem$t[d[1]+k] + do j = 2, n[i] + sum = sum + Mem$t[d[j]+k] + if (doaverage == YES) + average[i] = sum / n[i] + else + average[i] = sum + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + wt = wts[Memi[m[1]+k]] + sum = Mem$t[d[1]+k] * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + Mem$t[d[j]+k] * wt + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sum / sumwt + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + if (doaverage == YES) + average[i] = sum / n1 + else + average[i] = sum + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/iccclip.gx b/pkg/images/immatch/src/imcombine/src/iccclip.gx new file mode 100644 index 00000000..5b1b724e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/iccclip.gx @@ -0,0 +1,471 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 2 # Mininum number of images for algorithm + +$for (sird) +# IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average + +procedure ic_accdclip$t (d, m, n, scales, zeros, nm, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model parameters +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, r, zero +data zero /0.0/ +$else +PIXEL d1, low, high, sum, a, s, r, zero +data zero /0$f/ +$endif +pointer sp, resid, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are no pixels go on to the combining. Since the unweighted + # average is computed here possibly skip the combining later. + + # There must be at least max (1, nkeep) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } else if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # There must be at least two pixels for rejection. The initial + # average is the low/high rejected average except in the case of + # just two pixels. The rejections are iterated and the average + # is recomputed. Corrections for scaling may be performed. + # Depending on other flags the image IDs may also need to be adjusted. + + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 <= max (MINCLIP-1, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + repeat { + if (n1 == 2) { + sum = Mem$t[d[1]+k] + sum = sum + Mem$t[d[2]+k] + a = sum / 2 + } else { + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + } + n2 = n1 + if (doscale1) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + + l = Memi[mp1] + s = scales[l] + d1 = max (zero, s * (a + zeros[l])) + s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s + + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[n1] + k + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } else { + if (!keepids) { + s = max (zero, a) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (j=1; j<=n1; j=j+1) { + if (keepids) { + l = Memi[m[j]+k] + s = max (zero, a) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs(r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + } + + n[i] = n1 + if (!docombine) + if (n1 > 0) + average[i] = sum / n1 + else + average[i] = blank + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median + +procedure ic_mccdclip$t (d, m, n, scales, zeros, nm, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real nm[3,nimages] # Noise model +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med, zero +data zero /0.0/ +$else +PIXEL med, zero +data zero /0$f/ +$endif + +include "../icombine.com" + +begin + # There must be at least max (MINCLIP, nkeep+1) pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) { + med = Mem$t[d[n3-1]+k] + med = (med + Mem$t[d[n3]+k]) / 2. + } else + med = Mem$t[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + for (; nl <= nh; nl = nl + 1) { + l = Memi[m[nl]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + l = Memi[m[nh]+k] + s = scales[l] + r = max (zero, s * (med + zeros[l])) + s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } else { + if (!keepids) { + s = max (zero, med) + s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) + } + for (; nl <= nh; nl = nl + 1) { + if (keepids) { + l = Memi[m[nl]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + if (keepids) { + l = Memi[m[nh]+k] + s = max (zero, med) + s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) + } + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median is computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icemask.x b/pkg/images/immatch/src/imcombine/src/icemask.x new file mode 100644 index 00000000..e29edd5e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icemask.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# IC_EMASK -- Create exposure mask. + +procedure ic_emask (pm, v, id, nimages, n, wts, npts) + +pointer pm #I Pixel mask +long v[ARB] #I Output vector +pointer id[nimages] #I Image id pointers +int nimages #I Number of images +int n[npts] #I Number of good pixels +real wts[npts] #I Weights +int npts #I Number of output pixels per line + +int i, j, k, impnli() +real exp +pointer buf +errchk impnli + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + # Write scaling factors to the header. + if (einit == NO) { + if (ezero != 0. || escale != 1.) { + call imaddr (pm, "MASKZERO", ezero) + call imaddr (pm, "MASKSCAL", escale) + } + einit = YES + } + + call amovl (v, Meml[ev], IM_MAXDIM) + i = impnli (pm, buf, Meml[ev]) + call aclri (Memi[buf], npts) + do i = 1, npts { + exp = 0. + do j = 1, n[i] { + k = Memi[id[j]+i-1] + if (wts[k] > 0.) + exp = exp + Memr[exps+k-1] + } + Memi[buf] = nint((exp-ezero)/escale) + buf = buf + 1 + } +end + + +# IC_EINIT -- Initialize exposure mask. + +procedure ic_einit (in, nimages, key, default, maxval) + +int in[nimages] #I Image pointers +int nimages #I Number of images +char key[ARB] #I Exposure time keyword +real default #I Default exposure time +int maxval #I Maximum mask value + +int i +real exp, emin, emax, efrac, imgetr() + +pointer exps # Exposure times +pointer ev # IMIO coordinate vector +real ezero # Integer to real zero +real escale # Integer to real scale +int einit # Initialization flag +common /emask/ exps, ev, ezero, escale, einit + +begin + call malloc (ev, IM_MAXDIM, TY_LONG) + call malloc (exps, nimages, TY_REAL) + + emax = 0. + emin = MAX_REAL + efrac = 0 + do i = 1, nimages { + iferr (exp = imgetr (in[i], key)) + exp = default + exp = max (0., exp) + emax = emax + exp + if (exp > 0.) + emin = min (exp, emin) + efrac = max (abs(exp-nint(exp)), efrac) + Memr[exps+i-1] = exp + } + + # Set scaling. + ezero = 0. + escale = 1. + if (emin < 1.) { + escale = emin + emin = emin / escale + emax = emax / escale + } else if (emin == MAX_REAL) + emin = 0. + if (efrac > 0.001 && emax-emin < 1000.) { + escale = escale / 1000. + emin = emin * 1000. + emax = emax * 1000. + } + while (emax > maxval) { + escale = escale * 10. + emin = emin / 10. + emax = emax / 10. + } + einit = NO +end diff --git a/pkg/images/immatch/src/imcombine/src/icgdata.gx b/pkg/images/immatch/src/imcombine/src/icgdata.gx new file mode 100644 index 00000000..a05f5646 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgdata.gx @@ -0,0 +1,396 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" + +$for (sird) +# IC_GDATA -- Get line of image and mask data and apply threshold and scaling. +# Entirely empty lines are excluded. The data are compacted within the +# input data buffers. If it is required, the connection to the original +# image index is kept in the returned m data pointers. + +procedure ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, + zeros, nimages, npts, v1, v2) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +pointer dbuf[nimages] # Data buffers +pointer d[nimages] # Data pointers +pointer id[nimages] # ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Empty mask flags +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +int nimages # Number of input images +int npts # NUmber of output points per line +long v1[ARB], v2[ARB] # Line vectors + +PIXEL temp +int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnl$t() +real a, b +pointer buf, dp, ip, mp +errchk xt_cpix, xt_imgnl$t + +PIXEL max_pixel +$if (datatype == s) +data max_pixel/MAX_SHORT/ +$else $if (datatype == i) +data max_pixel/MAX_INT/ +$else $if (datatype == r) +data max_pixel/MAX_REAL/ +$else +data max_pixel/MAX_DOUBLE/ +$endif $endif $endif + +include "../icombine.com" + +begin + # Get masks and return if there is no data + call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + if (dflag == D_NONE) { + call aclri (n, npts) + return + } + + # Close images which are not needed. + nout = IM_LEN(out[1],1) + ndim = IM_NDIM(out[1]) + if (!project && ndim < 3) { + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + call xt_cpix (i) + if (ndim > 1) { + j = v1[2] - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + } + } + + # Get data and fill data buffers. Correct for offsets if needed. + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (dbuf[i] == NULL) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = xt_imgnl$t (in[i], i, d[i], v2, v1[2]) + } else { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) { + lflag[i] = D_NONE + next + } + k = 1 + j - offsets[i,1] + v2[1] = k + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + if (lflag[i] == D_NONE) + next + if (project) + v2[ndim+1] = i + l = xt_imgnl$t (in[i], i, buf, v2, v1[2]) + call amov$t (Mem$t[buf+k-1], Mem$t[dbuf[i]+j], npix) + d[i] = dbuf[i] + } + } + + # Set values to max_pixel if needed. + if (mtype == M_NOVAL) { + do i = 1, nimages { + dp = d[i]; mp = m[i] + if (lflag[i] == D_NONE || dp == NULL) + next + else if (lflag[i] == D_MIX) { + do j = 1, npts { + if (Memi[mp] == 1) + Mem$t[dp] = max_pixel + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + + lflag[i] = D_MIX + dflag = D_MIX + } + dp = dp + 1 + } + + # Check for completely empty lines + if (lflag[i] == D_MIX) { + lflag[i] = D_NONE + mp = m[i] + do j = 1, npts { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) { + a = Mem$t[dp] + if (a < lthresh || a > hthresh) { + if (mtype == M_NOVAL) + Memi[m[i]+j-1] = 2 + else + Memi[m[i]+j-1] = 1 + dflag = D_MIX + } + } + dp = dp + 1 + mp = mp + 1 + } + + # Check for completely empty lines + lflag[i] = D_NONE + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + lflag[i] = D_MIX + break + } + mp = mp + 1 + } + } + } + } + + # Apply scaling (avoiding masked pixels which might overflow?) + if (doscale) { + if (dflag == D_ALL) { + do i = 1, nimages { + dp = d[i] + a = scales[i] + b = -zeros[i] + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } + } else if (dflag == D_MIX) { + do i = 1, nimages { + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + dp = d[i] + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] != 1) + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + mp = mp + 1 + } + } + } + } + } + + # Sort pointers to exclude unused images. + # Use the lflag array to keep track of the image index. + + if (dflag == D_ALL) + nused = nimages + else { + nused = 0 + do i = 1, nimages { + if (lflag[i] != D_NONE) { + nused = nused + 1 + d[nused] = d[i] + m[nused] = m[i] + lflag[nused] = i + } + } + do i = nused+1, nimages + d[i] = NULL + if (nused == 0) + dflag = D_NONE + } + + # Compact data to remove bad pixels + # Keep track of the image indices if needed + # If growing mark the end of the included image indices with zero + + if (dflag == D_ALL) { + call amovki (nused, n, npts) + if (keepids) + do i = 1, nimages + call amovki (i, Memi[id[i]], npts) + } else if (dflag == D_NONE) + call aclri (n, npts) + else { + call aclri (n, npts) + if (keepids) { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + ip = id[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + Memi[ip] = l + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mem$t[d[k]+j-1] + Mem$t[d[k]+j-1] = Mem$t[dp] + Mem$t[dp] = temp + Memi[ip] = Memi[id[k]+j-1] + Memi[id[k]+j-1] = l + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } else + Memi[ip] = 0 + dp = dp + 1 + ip = ip + 1 + mp = mp + 1 + } + } + if (grow >= 1.) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + l = lflag[i] + nin = IM_LEN(in[l],1) + j = max (0, offsets[l,1]) + k = min (nout, nin + offsets[l,1]) + npix = k - j + n1 = 1 + j + n2 = n1 + npix - 1 + dp = d[i] + n1 - 1 + mp = m[i] + n1 - 1 + do j = n1, n2 { + if (Memi[mp] == 0) { + n[j] = n[j] + 1 + k = n[j] + if (k < i) { + temp = Mem$t[d[k]+j-1] + Mem$t[d[k]+j-1] = Mem$t[dp] + Mem$t[dp] = temp + Memi[mp] = Memi[m[k]+j-1] + Memi[m[k]+j-1] = 0 + } + } + dp = dp + 1 + mp = mp + 1 + } + } + } + } + + # Sort the pixels and IDs if needed + if (mclip) { + call malloc (dp, nused, TY_PIXEL) + if (keepids) { + call malloc (ip, nused, TY_INT) + call ic_2sort$t (d, Mem$t[dp], id, Memi[ip], n, npts) + call mfree (ip, TY_INT) + } else + call ic_sort$t (d, Mem$t[dp], n, npts) + call mfree (dp, TY_PIXEL) + } + + # If no good pixels set the number of usable values as -n and + # shift them to lower values. + if (mtype == M_NOVAL) { + if (keepids) { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + ip = id[i] + j - 1 + if (Mem$t[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) { + Mem$t[d[k]+j-1] = Mem$t[dp] + Memi[id[k]+j-1] = Memi[ip] + } + } + } + } + } else { + do j = 1, npts { + if (n[j] > 0) + next + n[j] = 0 + do i = 1, nused { + dp = d[i] + j - 1 + if (Mem$t[dp] < max_pixel) { + n[j] = n[j] - 1 + k = -n[j] + if (k < i) + Mem$t[d[k]+j-1] = Mem$t[dp] + } + } + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icgrow.gx b/pkg/images/immatch/src/imcombine/src/icgrow.gx new file mode 100644 index 00000000..caf7dd29 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgrow.gx @@ -0,0 +1,135 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" + +# IC_GROW -- Mark neigbors of rejected pixels. +# The rejected pixels (original plus grown) are saved in pixel masks. + +procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) + +pointer out # Output image pointer +long v[ARB] # Output vector +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[npts,nimages] # Working buffer +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() +real grow2, i2 +pointer mp, pm, pm_newmask() +errchk pm_newmask() + +include "../icombine.com" + +begin + if (dflag == D_NONE || grow == 0.) + return + + line = v[2] + nl = IM_LEN(out,2) + rop = or (PIX_SRC, PIX_DST) + + igrow = grow + grow2 = grow**2 + do l = 0, igrow { + i2 = grow2 - l * l + call aclri (buf, npts*nimages) + nset = 0 + do j = 1, npts { + do k = n[j]+1, nimages { + mp = Memi[m[k]+j-1] + if (mp == 0) + next + do i = 0, igrow { + if (i**2 > i2) + next + if (j > i) + buf[j-i,mp] = 1 + if (j+i <= npts) + buf[j+i,mp] = 1 + nset = nset + 1 + } + } + } + if (nset == 0) + return + + if (pms == NULL) { + call malloc (pms, nimages, TY_POINTER) + do i = 1, nimages + Memi[pms+i-1] = pm_newmask (out, 1) + ncompress = 0 + } + do i = 1, nimages { + pm = Memi[pms+i-1] + v[2] = line - l + if (v[2] > 0) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + if (l > 0) { + v[2] = line + l + if (v[2] <= nl) + call pmplpi (pm, v, buf[1,i], 1, npts, rop) + } + } + } + v[2] = line + + if (ncompress > 10) { + do i = 1, nimages { + pm = Memi[pms+i-1] + call pm_compress (pm) + } + ncompress = 0 + } else + ncompress = ncompress + 1 +end + + +$for (sird) +# IC_GROW$T -- Reject pixels. + +procedure ic_grow$t (v, d, m, n, buf, nimages, npts, pms) + +long v[ARB] # Output vector +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[ARB] # Number of good pixels +int buf[ARB] # Buffer of npts +int nimages # Number of images +int npts # Number of output points per line +pointer pms # Pointer to array of pixel masks + +int i, j, k +pointer pm +bool pl_linenotempty() + +include "../icombine.com" + +begin + do k = 1, nimages { + pm = Memi[pms+k-1] + if (!pl_linenotempty (pm, v)) + next + call pmglpi (pm, v, buf, 1, npts, PIX_SRC) + do i = 1, npts { + if (buf[i] == 0) + next + for (j = 1; j <= n[i]; j = j + 1) { + if (Memi[m[j]+i-1] == k) { + if (j < n[i]) { + Mem$t[d[j]+i-1] = Mem$t[d[n[i]]+i-1] + Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] + } + n[i] = n[i] - 1 + dflag = D_MIX + break + } + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icgscale.x b/pkg/images/immatch/src/imcombine/src/icgscale.x new file mode 100644 index 00000000..570697ad --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icgscale.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "icombine.h" + + +# IC_GSCALE -- Get scale values as directed by CL parameter. +# Only those values which are INDEF are changed. +# The values can be one of those in the dictionary, from a file specified +# with a @ prefix, or from an image header keyword specified by a ! prefix. + +int procedure ic_gscale (param, name, dic, in, exptime, values, nimages) + +char param[ARB] #I CL parameter name +char name[SZ_FNAME] #O Parameter value +char dic[ARB] #I Dictionary string +pointer in[nimages] #I IMIO pointers +real exptime[nimages] #I Exposure times +real values[nimages] #O Values +int nimages #I Number of images + +int type #O Type of value + +int fd, i, nowhite(), open(), fscan(), nscan(), strdic() +real rval, imgetr() +pointer errstr +errchk open, imgetr + +include "icombine.com" + +begin + call clgstr (param, name, SZ_FNAME) + if (nowhite (name, name, SZ_FNAME) == 0) + type = S_NONE + else if (name[1] == '@') { + type = S_FILE + do i = 1, nimages + if (IS_INDEFR(values[i])) + break + if (i <= nimages) { + fd = open (name[2], READ_ONLY, TEXT_FILE) + i = 0 + while (fscan (fd) != EOF) { + call gargr (rval) + if (nscan() != 1) + next + if (i == nimages) { + call eprintf ( + "Warning: Ignoring additional %s values in %s\n") + call pargstr (param) + call pargstr (name[2]) + break + } + i = i + 1 + if (IS_INDEFR(values[i])) + values[i] = rval + } + call close (fd) + if (i < nimages) { + call salloc (errstr, SZ_LINE, TY_CHAR) + call sprintf (errstr, SZ_FNAME, + "Insufficient %s values in %s") + call pargstr (param) + call pargstr (name[2]) + call error (1, errstr) + } + } + } else if (name[1] == '!') { + type = S_KEYWORD + do i = 1, nimages { + if (IS_INDEFR(values[i])) + values[i] = imgetr (in[i], name[2]) + if (project) { + call amovkr (values, values, nimages) + break + } + } + } else { + type = strdic (name, name, SZ_FNAME, dic) + if (type == 0) + call error (1, "Unknown scale, zero, or weight type") + if (type==S_EXPOSURE) + do i = 1, nimages + if (IS_INDEFR(values[i])) + values[i] = max (0.001, exptime[i]) + } + + return (type) +end diff --git a/pkg/images/immatch/src/imcombine/src/ichdr.x b/pkg/images/immatch/src/imcombine/src/ichdr.x new file mode 100644 index 00000000..b4d925c1 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/ichdr.x @@ -0,0 +1,72 @@ +include + + +# IC_HDR -- Set output header. + +procedure ic_hdr (in, out, nimages) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images + +int i, j, imgnfn(), nowhite(), strldxs() +pointer sp, inkey, key, str, list, imofnlu() +bool streq() + +begin + call smark (sp) + call salloc (inkey, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + call clgstr ("imcmb", Memc[inkey], SZ_FNAME) + i = nowhite (Memc[inkey], Memc[inkey], SZ_FNAME) + + if (i > 0 && streq (Memc[inkey], "$I")) { + # Set new PROCID. + call xt_procid (out) + + # Set input PROCIDs. + if (nimages < 100) { + list = imofnlu (out, "PROCID[0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + call sprintf (Memc[key], 8, "PROCID%02d") + call pargi (i) + iferr (call imgstr (in[i], "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (in[i], "OBSID", Memc[str], SZ_LINE)) + Memc[str] = EOS + } + if (Memc[str] != EOS) + call imastr (out, Memc[key], Memc[str]) + } + } + } + + if (i > 0 && nimages < 1000) { + list = imofnlu (out, "IMCMB[0-9][0-9][0-9]") + while (imgnfn (list, Memc[key], SZ_LINE) != EOF) + call imdelf (out, Memc[key]) + call imcfnl (list) + do i = 1, nimages { + if (streq (Memc[inkey], "$I")) { + call imstats (in[i], IM_IMAGENAME, Memc[str], SZ_LINE) + j = strldxs ("/$", Memc[str]) + if (j > 0) + call strcpy (Memc[str+j], Memc[str], SZ_LINE) + } else { + iferr (call imgstr (in[i], Memc[inkey], Memc[str], SZ_LINE)) + Memc[str] = EOS + } + if (Memc[str] == EOS) + next + call sprintf (Memc[key], SZ_LINE, "IMCMB%03d") + call pargi (i) + call imastr (out, Memc[key], Memc[str]) + } + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icimstack.x b/pkg/images/immatch/src/imcombine/src/icimstack.x new file mode 100644 index 00000000..d5628694 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icimstack.x @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + + +# IC_IMSTACK -- Stack images into a single image of higher dimension. + +procedure ic_imstack (list, output, mask) + +int list #I List of images +char output[ARB] #I Name of output image +char mask[ARB] #I Name of output mask + +int i, j, npix +long line_in[IM_MAXDIM], line_out[IM_MAXDIM], line_outbpm[IM_MAXDIM] +pointer sp, input, bpmname, key, in, out, inbpm, outbpm, buf_in, buf_out, ptr + +int imtgetim(), imtlen(), errget() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap(), pm_newmask() +errchk immap +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (bpmname, SZ_FNAME, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + + iferr { + # Add each input image to the output image. + out = NULL; outbpm = NULL + i = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + + i = i + 1 + in = NULL; inbpm = NULL + ptr = immap (Memc[input], READ_ONLY, 0) + in = ptr + + # For the first input image map the output image as a copy + # and increment the dimension. Set the output line counter. + + if (i == 1) { + ptr = immap (output, NEW_COPY, in) + out = ptr + IM_NDIM(out) = IM_NDIM(out) + 1 + IM_LEN(out, IM_NDIM(out)) = imtlen (list) + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, IM_MAXDIM) + + if (mask[1] != EOS) { + ptr = immap (mask, NEW_COPY, in) + outbpm = ptr + IM_NDIM(outbpm) = IM_NDIM(outbpm) + 1 + IM_LEN(outbpm, IM_NDIM(outbpm)) = imtlen (list) + call amovkl (long(1), line_outbpm, IM_MAXDIM) + } + } + + # Check next input image for consistency with the output image. + if (IM_NDIM(in) != IM_NDIM(out) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(in) { + if (IM_LEN(in, j) != IM_LEN(out, j)) + call error (0, "Input images not consistent") + } + + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + call imastr (out, Memc[key], Memc[input]) + + # Copy the input lines from the image to the next lines of + # the output image. Switch on the output data type to optimize + # IMIO. + + call amovkl (long(1), line_in, IM_MAXDIM) + switch (IM_PIXTYPE (out)) { + case TY_SHORT: + while (imgnls (in, buf_in, line_in) != EOF) { + if (impnls (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + case TY_INT: + while (imgnli (in, buf_in, line_in) != EOF) { + if (impnli (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + case TY_USHORT, TY_LONG: + while (imgnll (in, buf_in, line_in) != EOF) { + if (impnll (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + case TY_REAL: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf_in, line_in) != EOF) { + if (impnld (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf_in, line_in) != EOF) { + if (impnlx (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovx (Memx[buf_in], Memx[buf_out], npix) + } + default: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + } + + # Copy mask. + if (mask[1] != EOS) { + iferr (call imgstr (in, "bpm", Memc[bpmname], SZ_FNAME)) { + Memc[bpmname] = EOS + ptr = pm_newmask (in, 27) + } else + ptr = immap (Memc[bpmname], READ_ONLY, 0) + inbpm = ptr + + if (IM_NDIM(inbpm) != IM_NDIM(outbpm) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(inbpm) { + if (IM_LEN(inbpm, j) != IM_LEN(outbpm, j)) + call error (0, "Masks not consistent") + } + + call amovkl (long(1), line_in, IM_MAXDIM) + while (imgnli (inbpm, buf_in, line_in) != EOF) { + if (impnli (outbpm, buf_out, line_outbpm) == EOF) + call error (0, "Error writing output mask") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + call imastr (out, Memc[key], Memc[bpmname]) + + call imunmap (inbpm) + } + + call imunmap (in) + } + } then { + i = errget (Memc[key], SZ_FNAME) + call erract (EA_WARN) + if (outbpm != NULL) { + call imunmap (outbpm) + iferr (call imdelete (mask)) + ; + } + if (out != NULL) { + call imunmap (out) + iferr (call imdelete (output)) + ; + } + if (inbpm != NULL) + call imunmap (inbpm) + if (in != NULL) + call imunmap (in) + call sfree (sp) + call error (i, "Can't make temporary stack images") + } + + # Finish up. + if (outbpm != NULL) { + call imunmap (outbpm) + call imastr (out, "bpm", mask) + } + call imunmap (out) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/iclog.x b/pkg/images/immatch/src/imcombine/src/iclog.x new file mode 100644 index 00000000..53420cd5 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/iclog.x @@ -0,0 +1,431 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "icombine.h" +include "icmask.h" + +# IC_LOG -- Output log information is a log file has been specfied. + +procedure ic_log (in, out, ncombine, exptime, sname, zname, wname, + mode, median, mean, scales, zeros, wts, offsets, nimages, + dozero, nout) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int ncombine[nimages] # Number of previous combined images +real exptime[nimages] # Exposure times +char sname[ARB] # Scale name +char zname[ARB] # Zero name +char wname[ARB] # Weight name +real mode[nimages] # Modes +real median[nimages] # Medians +real mean[nimages] # Means +real scales[nimages] # Scale factors +real zeros[nimages] # Zero or sky levels +real wts[nimages] # Weights +int offsets[nimages,ARB] # Image offsets +int nimages # Number of images +bool dozero # Zero flag +int nout # Number of images combined in output + +int i, j, stack, ctor() +real rval, imgetr() +long clktime() +bool prncombine, prexptime, prmode, prmedian, prmean, prmask +bool prrdn, prgain, prsn +pointer sp, fname, bpname, key +errchk imgetr + +include "icombine.com" + +begin + if (logfd == NULL) + return + + call smark (sp) + call salloc (fname, SZ_LINE, TY_CHAR) + call salloc (bpname, SZ_LINE, TY_CHAR) + + stack = NO + if (project) { + ifnoerr (call imgstr (in[1], "stck0001", Memc[fname], SZ_LINE)) + stack = YES + } + if (stack == YES) + call salloc (key, SZ_FNAME, TY_CHAR) + + # Time stamp the log and print parameter information. + + call cnvdate (clktime(0), Memc[fname], SZ_LINE) + call fprintf (logfd, "\n%s: IMCOMBINE\n") + call pargstr (Memc[fname]) + switch (combine) { + case AVERAGE: + call fprintf (logfd, " combine = average, ") + case MEDIAN: + call fprintf (logfd, " combine = median, ") + case SUM: + call fprintf (logfd, " combine = sum, ") + } + call fprintf (logfd, "scale = %s, zero = %s, weight = %s\n") + call pargstr (sname) + call pargstr (zname) + call pargstr (wname) + if (combine == NMODEL && reject!=CCDCLIP && reject!=CRREJECT) { + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + } + + switch (reject) { + case MINMAX: + call fprintf (logfd, " reject = minmax, nlow = %d, nhigh = %d\n") + call pargi (nint (flow * nimages)) + call pargi (nint (fhigh * nimages)) + case CCDCLIP: + call fprintf (logfd, " reject = ccdclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s, sigma = %g, hsigma = %g\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + call pargr (lsigma) + call pargr (hsigma) + case CRREJECT: + call fprintf (logfd, + " reject = crreject, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, + " rdnoise = %s, gain = %s, snoise = %s, hsigma = %g\n") + call pargstr (Memc[rdnoise]) + call pargstr (Memc[gain]) + call pargstr (Memc[snoise]) + call pargr (hsigma) + case PCLIP: + call fprintf (logfd, " reject = pclip, nkeep = %d\n") + call pargi (nkeep) + call fprintf (logfd, " pclip = %g, lsigma = %g, hsigma = %g\n") + call pargr (pclip) + call pargr (lsigma) + call pargr (hsigma) + case SIGCLIP: + call fprintf (logfd, " reject = sigclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, " lsigma = %g, hsigma = %g\n") + call pargr (lsigma) + call pargr (hsigma) + case AVSIGCLIP: + call fprintf (logfd, + " reject = avsigclip, mclip = %b, nkeep = %d\n") + call pargb (mclip) + call pargi (nkeep) + call fprintf (logfd, " lsigma = %g, hsigma = %g\n") + call pargr (lsigma) + call pargr (hsigma) + } + if (reject != NONE && grow >= 1.) { + call fprintf (logfd, " grow = %g\n") + call pargr (grow) + } + if (dothresh) { + if (lthresh > -MAX_REAL && hthresh < MAX_REAL) { + call fprintf (logfd, " lthreshold = %g, hthreshold = %g\n") + call pargr (lthresh) + call pargr (hthresh) + } else if (lthresh > -MAX_REAL) { + call fprintf (logfd, " lthreshold = %g\n") + call pargr (lthresh) + } else { + call fprintf (logfd, " hthreshold = %g\n") + call pargr (hthresh) + } + } + call fprintf (logfd, " blank = %g\n") + call pargr (blank) + if (Memc[statsec] != EOS) { + call fprintf (logfd, " statsec = %s\n") + call pargstr (Memc[fname]) + } + + if (ICM_TYPE(icm) != M_NONE) { + switch (ICM_TYPE(icm)) { + case M_BOOLEAN, M_GOODVAL: + call fprintf (logfd, " masktype = goodval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADVAL: + call fprintf (logfd, " masktype = badval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_NOVAL: + call fprintf (logfd, " masktype = noval, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_GOODBITS: + call fprintf (logfd, " masktype = goodbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_BADBITS: + call fprintf (logfd, " masktype = badbits, maskval = %d\n") + call pargi (ICM_VALUE(icm)) + case M_LTVAL: + call fprintf (logfd, " masktype = goodval, maskval < %d\n") + call pargi (ICM_VALUE(icm)) + case M_GTVAL: + call fprintf (logfd, " masktype = goodval, maskval > %d\n") + call pargi (ICM_VALUE(icm)) + } + } + + # Print information pertaining to individual images as a set of + # columns with the image name being the first column. Determine + # what information is relevant and print the appropriate header. + + prncombine = false + prexptime = false + prmode = false + prmedian = false + prmean = false + prmask = false + prrdn = false + prgain = false + prsn = false + do i = 1, nimages { + if (ncombine[i] != ncombine[1]) + prncombine = true + if (exptime[i] != exptime[1]) + prexptime = true + if (mode[i] != mode[1]) + prmode = true + if (median[i] != median[1]) + prmedian = true + if (mean[i] != mean[1]) + prmean = true + if (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_NAMES(icm)] + else + bpname = Memi[ICM_NAMES(icm)+i-1] + if (Memc[bpname] != EOS) + prmask = true + } + if (combine == NMODEL || reject == CCDCLIP || reject == CRREJECT) { + j = 1 + if (ctor (Memc[rdnoise], j, rval) == 0) + prrdn = true + j = 1 + if (ctor (Memc[gain], j, rval) == 0) + prgain = true + j = 1 + if (ctor (Memc[snoise], j, rval) == 0) + prsn = true + } + } + + call fprintf (logfd, " %20s ") + call pargstr ("Images") + if (prncombine) { + call fprintf (logfd, " %6s") + call pargstr ("N") + } + if (prexptime) { + call fprintf (logfd, " %6s") + call pargstr ("Exp") + } + if (prmode) { + call fprintf (logfd, " %7s") + call pargstr ("Mode") + } + if (prmedian) { + call fprintf (logfd, " %7s") + call pargstr ("Median") + } + if (prmean) { + call fprintf (logfd, " %7s") + call pargstr ("Mean") + } + if (prrdn) { + call fprintf (logfd, " %7s") + call pargstr ("Rdnoise") + } + if (prgain) { + call fprintf (logfd, " %6s") + call pargstr ("Gain") + } + if (prsn) { + call fprintf (logfd, " %6s") + call pargstr ("Snoise") + } + if (doscale) { + call fprintf (logfd, " %6s") + call pargstr ("Scale") + } + if (dozero) { + call fprintf (logfd, " %7s") + call pargstr ("Zero") + } + if (dowts) { + call fprintf (logfd, " %6s") + call pargstr ("Weight") + } + if (!aligned) { + call fprintf (logfd, " %9s") + call pargstr ("Offsets") + } + if (prmask) { + call fprintf (logfd, " %s") + call pargstr ("Maskfile") + } + call fprintf (logfd, "\n") + + do i = 1, nimages { + if (stack == YES) { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], SZ_LINE)) { + call fprintf (logfd, " %21s") + call pargstr (Memc[fname]) + } else { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %16s[%3d]") + call pargstr (Memc[fname]) + call pargi (i) + } + } else if (project) { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %16s[%3d]") + call pargstr (Memc[fname]) + call pargi (i) + } else { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " %21s") + call pargstr (Memc[fname]) + } + if (prncombine) { + call fprintf (logfd, " %6d") + call pargi (ncombine[i]) + } + if (prexptime) { + call fprintf (logfd, " %6.1f") + call pargr (exptime[i]) + } + if (prmode) { + call fprintf (logfd, " %7.5g") + call pargr (mode[i]) + } + if (prmedian) { + call fprintf (logfd, " %7.5g") + call pargr (median[i]) + } + if (prmean) { + call fprintf (logfd, " %7.5g") + call pargr (mean[i]) + } + if (prrdn) { + rval = imgetr (in[i], Memc[rdnoise]) + call fprintf (logfd, " %7g") + call pargr (rval) + } + if (prgain) { + rval = imgetr (in[i], Memc[gain]) + call fprintf (logfd, " %6g") + call pargr (rval) + } + if (prsn) { + rval = imgetr (in[i], Memc[snoise]) + call fprintf (logfd, " %6g") + call pargr (rval) + } + if (doscale) { + call fprintf (logfd, " %6.3f") + call pargr (1./scales[i]) + } + if (dozero) { + call fprintf (logfd, " %7.5g") + call pargr (-zeros[i]) + } + if (dowts) { + call fprintf (logfd, " %6.3f") + call pargr (wts[i]) + } + if (!aligned) { + if (IM_NDIM(out[1]) == 1) { + call fprintf (logfd, " %9d") + call pargi (offsets[i,1]) + } else { + do j = 1, IM_NDIM(out[1]) { + call fprintf (logfd, " %4d") + call pargi (offsets[i,j]) + } + } + } + if (prmask) { + if (stack == YES) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], + SZ_LINE)) { + call fprintf (logfd, " %s") + call pargstr (Memc[fname]) + } else { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } else if (ICM_TYPE(icm) != M_NONE) { + if (project) + bpname = Memi[ICM_NAMES(icm)] + else + bpname = Memi[ICM_NAMES(icm)+i-1] + if (Memc[bpname] != EOS) { + call fprintf (logfd, " %s") + call pargstr (Memc[bpname]) + } + } + } + call fprintf (logfd, "\n") + } + + # Log information about the output images. + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, "\n Output image = %s, ncombine = %d") + call pargstr (Memc[fname]) + call pargi (nout) + call fprintf (logfd, "\n") + + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Bad pixel mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[4] != NULL) { + call imstats (out[4], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Rejection mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[5] != NULL) { + call imstats (out[5], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Number rejected mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[6] != NULL) { + call imstats (out[6], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Exposure mask = %s\n") + call pargstr (Memc[fname]) + } + + if (out[3] != NULL) { + call imstats (out[3], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Sigma image = %s\n") + call pargstr (Memc[fname]) + } + + call flush (logfd) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icmask.com b/pkg/images/immatch/src/imcombine/src/icmask.com new file mode 100644 index 00000000..baba6f6a --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmask.com @@ -0,0 +1,8 @@ +# IMCMASK -- Common for IMCOMBINE mask interface. + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +common /imcmask/ mtype, mvalue, bufs, pms diff --git a/pkg/images/immatch/src/imcombine/src/icmask.h b/pkg/images/immatch/src/imcombine/src/icmask.h new file mode 100644 index 00000000..ffb64aa9 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmask.h @@ -0,0 +1,12 @@ +# ICMASK -- Data structure for IMCOMBINE mask interface. + +define ICM_LEN 6 # Structure length +define ICM_TYPE Memi[$1] # Mask type +define ICM_VALUE Memi[$1+1] # Mask value +define ICM_IOMODE Memi[$1+2] # I/O mode +define ICM_BUFS Memi[$1+3] # Pointer to data line buffers +define ICM_PMS Memi[$1+4] # Pointer to array of PMIO pointers +define ICM_NAMES Memi[$1+5] # Pointer to array of mask names + +define ICM_OPEN 0 # Keep masks open +define ICM_CLOSED 1 # Keep masks closed diff --git a/pkg/images/immatch/src/imcombine/src/icmask.x b/pkg/images/immatch/src/imcombine/src/icmask.x new file mode 100644 index 00000000..ca9c1d02 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmask.x @@ -0,0 +1,685 @@ +include +include +include +include "icombine.h" +include "icmask.h" + +# IC_MASK -- ICOMBINE mask interface +# +# IC_MOPEN -- Initialize mask interface +# IC_MCLOSE -- Close the mask interface +# IC_MGET -- Get lines of mask pixels for all the images +# IC_MGET1 -- Get a line of mask pixels for the specified image +# IC_MCLOSE1-- Close a mask for the specified image index + + +# IC_MOPEN -- Initialize mask interface. + +procedure ic_mopen (in, out, nimages, offsets, iomode) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I Number of images +int offsets[nimages,ARB] #I Offsets to output image +int iomode #I I/O mode + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers +pointer names # Pointer to array of string pointers + +int i, j, k, nin, nout, npix, npms, nscan(), strdic(), ctor() +real rval +pointer sp, str, key, fname, title, image, pm, pm_open() +bool invert, pm_empty() +errchk calloc, pm_open, ic_pmload + +include "icombine.com" + +begin + icm = NULL + if (IM_NDIM(out[1]) == 0) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Determine the mask parameters and allocate memory. + # The mask buffers are initialize to all excluded so that + # output points outside the input data are always excluded + # and don't need to be set on a line-by-line basis. + + mtype = M_NONE + call clgstr ("masktype", Memc[str], SZ_LINE) + call sscan (Memc[str]) + call gargwrd (Memc[title], SZ_FNAME) + call gargwrd (Memc[key], SZ_FNAME) + i = nscan() + if (i > 0) { + if (Memc[title] == '!') { + if (i == 1) + mtype = M_GOODVAL + else + mtype = strdic (Memc[key], Memc[key], SZ_FNAME, MASKTYPES) + call strcpy (Memc[title+1], Memc[key], SZ_FNAME) + } else { + mtype = strdic (Memc[title], Memc[title], SZ_FNAME, MASKTYPES) + call strcpy ("BPM", Memc[key], SZ_FNAME) + } + if (mtype == 0) { + call sprintf (Memc[title], SZ_FNAME, + "Invalid or ambiguous masktype (%s)") + call pargstr (Memc[str]) + call error (1, Memc[title]) + } + } + npix = IM_LEN(out[1],1) + call calloc (pms, nimages, TY_POINTER) + call calloc (bufs, nimages, TY_POINTER) + call calloc (names, nimages, TY_POINTER) + do i = 1, nimages { + call malloc (Memi[bufs+i-1], npix, TY_INT) + call amovki (1, Memi[Memi[bufs+i-1]], npix) + } + + # Check for special cases. The BOOLEAN type is used when only + # zero and nonzero are significant; i.e. the actual mask values are + # not important. The invert flag is used to indicate that + # empty masks are all bad rather the all good. + + # Eventually we want to allow general expressions. For now we only + # allow a special '<' or '>' operator. + + call clgstr ("maskvalue", Memc[title], SZ_FNAME) + i = 1 + if (Memc[title] == '<') { + mtype = M_LTVAL + i = i + 1 + } else if (Memc[title] == '>') { + mtype = M_GTVAL + i = i + 1 + } + if (ctor (Memc[title], i, rval) == 0) + call error (1, "Bad mask value") + mvalue = rval + if (mvalue < 0) + call error (1, "Bad mask value") + else if (mvalue == 0 && mtype == M_NOVAL) + call error (1, "maskvalue cannot be 0 for masktype of 'novalue'") + + if (mtype == 0) + mtype = M_NONE + else if (mtype == M_BADBITS && mvalue == 0) + mtype = M_NONE + else if (mvalue == 0 && (mtype == M_GOODVAL || mtype == M_GOODBITS)) + mtype = M_BOOLEAN + else if ((mtype == M_BADVAL && mvalue == 0) || + (mtype == M_GOODVAL && mvalue != 0) || + (mtype == M_GOODBITS && mvalue == 0)) + invert = true + else + invert = false + + # If mask images are to be used, get the mask name from the image + # header and open it saving the descriptor in the pms array. + # Empty masks (all good) are treated as if there was no mask image. + + nout = IM_LEN(out[1],1) + npms = 0 + do i = 1, nimages { + if (mtype != M_NONE) { + call malloc (Memi[names+i-1], SZ_FNAME, TY_CHAR) + fname = Memi[names+i-1] + ifnoerr (call imgstr (in[i],Memc[key],Memc[fname],SZ_FNAME)) { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + if (npix < 1) + Memc[fname] = EOS + else { + pm = pm_open (NULL) + call ic_pmload (in[i], pm, Memc[fname], SZ_FNAME) + call pm_seti (pm, P_REFIM, in[i]) + if (pm_empty (pm) && !invert) + Memc[fname] = EOS + else { + if (project) + npms = nimages + else + npms = npms + 1 + } + call pm_close (pm) + } + if (project) + break + } else + Memc[fname] = EOS + } + } + + # If no mask images are found and the mask parameters imply that + # good values are 0 then use the special case of no masks. + + if (npms == 0) { + if (!invert) + mtype = M_NONE + } + + # Set up mask structure. + call calloc (icm, ICM_LEN, TY_STRUCT) + ICM_TYPE(icm) = mtype + ICM_VALUE(icm) = mvalue + ICM_IOMODE(icm) = iomode + ICM_BUFS(icm) = bufs + ICM_PMS(icm) = pms + ICM_NAMES(icm) = names + + call sfree (sp) +end + + +# IC_PMLOAD -- Find and load a mask. +# This is more complicated because we want to allow a mask name specified +# without a path to be found either in the current directory or in the +# directory of the image. + +procedure ic_pmload (im, pm, fname, maxchar) + +pointer im #I Image pointer to be associated with mask +pointer pm #O Mask pointer to be returned +char fname[ARB] #U Mask name +int maxchar #I Max size of mask name + +bool match +pointer sp, str, imname, yt_pmload() +int i, fnldir(), stridxs(), envfind() + +begin + call smark (sp) + call salloc (str, SZ_PATHNAME, TY_CHAR) + + # First check if the specified file can be loaded. + match = (envfind ("pmatch", Memc[str], SZ_PATHNAME) > 0) + if (match) { + call pm_close (pm) + iferr (pm = yt_pmload (fname,im,"logical",Memc[str],SZ_PATHNAME)) + pm = NULL + if (pm != NULL) + return + } else { + ifnoerr (call pm_loadf (pm, fname, Memc[str], SZ_PATHNAME)) + return + ifnoerr (call pm_loadim (pm, fname, Memc[str], SZ_PATHNAME)) + return + } + + # Check if the file has a path in which case we return an error. + # Must deal with possible [] which is a VMS directory delimiter. + call strcpy (fname, Memc[str], SZ_PATHNAME) + i = stridxs ("[", Memc[str]) + if (i > 0) + Memc[str+i-1] = EOS + if (fnldir (Memc[str], Memc[str], SZ_PATHNAME) > 0) { + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + } + + # Check if the image has a path. If not return an error. + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call imstats (im, IM_IMAGENAME, Memc[imname], SZ_PATHNAME) + if (fnldir (Memc[imname], Memc[str], SZ_PATHNAME) == 0) { + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + } + + # Try using the image path for the mask file. + call strcat (fname, Memc[str], SZ_PATHNAME) + if (match) { + iferr (pm = yt_pmload (Memc[imname], im, "logical", + Memc[str], SZ_PATHNAME)) + pm = NULL + if (pm != NULL) { + call strcpy (Memc[str], fname, maxchar) + return + } + } else { + ifnoerr (call pm_loadf (pm, Memc[str], Memc[imname], SZ_PATHNAME)) { + call strcpy (Memc[str], fname, maxchar) + return + } + } + + # No mask found. + call sprintf (Memc[str], SZ_PATHNAME, + "Bad pixel mask not found (%s)") + call pargstr (fname) + call error (1, Memc[str]) + + # This will not be reached and we let the calling program free + # the stack. We include smark/sfree for lint detectors. + call sfree (sp) +end + + + +# IC_MCLOSE -- Close the mask interface. + +procedure ic_mclose (nimages) + +int nimages # Number of images + +int i +include "icombine.com" + +begin + if (icm == NULL) + return + + do i = 1, nimages { + call mfree (Memi[ICM_NAMES(icm)+i-1], TY_CHAR) + call mfree (Memi[ICM_BUFS(icm)+i-1], TY_INT) + } + do i = 1, nimages { + if (Memi[ICM_PMS(icm)+i-1] != NULL) + call pm_close (Memi[ICM_PMS(icm)+i-1]) + if (project) + break + } + call mfree (ICM_NAMES(icm), TY_POINTER) + call mfree (ICM_BUFS(icm), TY_POINTER) + call mfree (ICM_PMS(icm), TY_POINTER) + call mfree (icm, TY_STRUCT) +end + + +# IC_MGET -- Get lines of mask pixels in the output coordinate system. +# This converts the mask format to an array where zero is good and nonzero +# is bad. This has special cases for optimization. + +procedure ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) + +pointer in[nimages] # Input image pointers +pointer out[ARB] # Output image pointer +int offsets[nimages,ARB] # Offsets to output image +long v1[IM_MAXDIM] # Data vector desired in output image +long v2[IM_MAXDIM] # Data vector in input image +pointer m[nimages] # Pointer to mask pointers +int lflag[nimages] # Line flags +int nimages # Number of images + +int mtype # Mask type +int mvalue # Mask value +int iomode # I/O mode +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, j, k, l, ndim, nin, nout, npix, envfind() +pointer buf, pm, names, fname, pm_open(), yt_pmload() +bool match, pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload + +include "icombine.com" + +begin + # Determine if masks are needed at all. Note that the threshold + # is applied by simulating mask values so the mask pointers have to + # be set. + + dflag = D_ALL + mtype = M_NONE + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE && aligned && !dothresh) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + iomode = ICM_IOMODE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + match = (envfind ("pmmatch", title, 1) > 0) + + # Set the mask pointers and line flags and apply offsets if needed. + + ndim = IM_NDIM(out[1]) + nout = IM_LEN(out[1],1) + do i = 1, nimages { + nin = IM_LEN(in[i],1) + j = max (0, offsets[i,1]) + k = min (nout, nin + offsets[i,1]) + npix = k - j + + m[i] = Memi[bufs+i-1] + buf = Memi[bufs+i-1] + j + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+i-1] + fname = Memi[names+i-1] + } + + if (npix < 1) + lflag[i] = D_NONE + else if (npix == nout) + lflag[i] = D_ALL + else + lflag[i] = D_MIX + + if (lflag[i] != D_NONE) { + v2[1] = 1 + j - offsets[i,1] + do l = 2, ndim { + v2[l] = v1[l] - offsets[i,l] + if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { + lflag[i] = D_NONE + break + } + } + } + if (project) + v2[ndim+1] = i + + if (lflag[i] == D_NONE) { + if (pm != NULL && !project) { + call pm_close (pm) + Memi[pms+i-1] = NULL + } + call amovki (1, Memi[m[i]], nout) + next + } else if (lflag[i] == D_MIX) { + if (j > 0) + call amovki (1, Memi[m[i]], j) + if (nout-k > 0) + call amovki (1, Memi[m[i]+k], nout-k) + } + + if (fname == NULL) { + call aclri (Memi[buf], npix) + next + } else if (Memc[fname] == EOS) { + call aclri (Memi[buf], npix) + next + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + if (pm == NULL) { + if (match) { + pm = yt_pmload (Memc[fname], in[i], "logical", + Memc[fname], SZ_FNAME) + } else { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in[i]) + } + if (project) + Memi[pms] = pm + else + Memi[pms+i-1] = pm + } + + if (pm_linenotempty (pm, v2)) { + call pm_glpi (pm, v2, Memi[buf], 32, npix, 0) + + if (mtype == M_BOOLEAN) + ; + else if (mtype == M_BADBITS) + call aandki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_BADVAL) + call abeqki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_NOVAL) { + do j = 0, npix-1 { + if (Memi[buf+j] == 0) + next + if (Memi[buf+j] == mvalue) + Memi[buf+j] = 1 + else + Memi[buf+j] = 2 + } + } else if (mtype == M_GOODBITS) { + call aandki (Memi[buf], mvalue, Memi[buf], npix) + call abeqki (Memi[buf], 0, Memi[buf], npix) + } else if (mtype == M_GOODVAL) + call abneki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_LTVAL) + call abgeki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GTVAL) + call ableki (Memi[buf], mvalue, Memi[buf], npix) + + lflag[i] = D_NONE + do j = 1, npix + if (Memi[buf+j-1] != 1) { + lflag[i] = D_MIX + break + } + } else { + if (mtype == M_BOOLEAN || mtype == M_BADBITS) { + call aclri (Memi[buf], npix) + } else if ((mtype == M_BADVAL && mvalue != 0) || + (mtype == M_NOVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + call aclri (Memi[buf], npix) + } else if (mtype == M_LTVAL && mvalue > 0) { + call aclri (Memi[buf], npix) + } else { + call amovki (1, Memi[buf], npix) + lflag[i] = D_NONE + } + } + + if (iomode == ICM_CLOSED) + call ic_mclose1 (i, nimages) + } + + # Set overall data flag + dflag = lflag[1] + do i = 2, nimages { + if (lflag[i] != dflag) { + dflag = D_MIX + break + } + } +end + + +# IC_MGET1 -- Get line of mask pixels from a specified image. +# This is used by the IC_STAT procedure. This procedure converts the +# stored mask format to an array where zero is good and nonzero is bad. +# The data vector and returned mask array are in the input image pixel system. + +procedure ic_mget1 (in, image, nimages, offset, v, m) + +pointer in # Input image pointer +int image # Image index +int nimages # Number of images +int offset # Column offset +long v[IM_MAXDIM] # Data vector desired +pointer m # Pointer to mask + +int mtype # Mask type +int mvalue # Mask value +pointer bufs # Pointer to data line buffers +pointer pms # Pointer to array of PMIO pointers + +char title[1] +int i, npix, envfind() +pointer buf, pm, names, fname, pm_open(), yt_pmload() +bool pm_linenotempty() +errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload + +include "icombine.com" + +begin + dflag = D_ALL + if (icm == NULL) + return + if (ICM_TYPE(icm) == M_NONE) + return + + mtype = ICM_TYPE(icm) + mvalue = ICM_VALUE(icm) + bufs = ICM_BUFS(icm) + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + npix = IM_LEN(in,1) + m = Memi[bufs+image-1] + offset + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL) + return + if (Memc[fname] == EOS) + return + + if (pm == NULL) { + if (envfind ("pmmatch", title, 1) > 0) { + pm = yt_pmload (Memc[fname], in, "logical", Memc[fname], + SZ_FNAME) + } else { + pm = pm_open (NULL) + iferr (call pm_loadf (pm, Memc[fname], title, 1)) + call pm_loadim (pm, Memc[fname], title, 1) + call pm_seti (pm, P_REFIM, in) + } + if (project) + Memi[pms] = pm + else + Memi[pms+image-1] = pm + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + buf = m + if (pm_linenotempty (pm, v)) { + call pm_glpi (pm, v, Memi[buf], 32, npix, 0) + + if (mtype == M_BOOLEAN) + ; + else if (mtype == M_BADBITS) + call aandki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_BADVAL) + call abeqki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_NOVAL) { + do i = 0, npix-1 { + if (Memi[buf+i] == 0) + next + if (Memi[buf+i] == mvalue) + Memi[buf+i] = 1 + else + Memi[buf+i] = 2 + } + } else if (mtype == M_GOODBITS) { + call aandki (Memi[buf], mvalue, Memi[buf], npix) + call abeqki (Memi[buf], 0, Memi[buf], npix) + } else if (mtype == M_GOODVAL) + call abneki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_LTVAL) + call abgeki (Memi[buf], mvalue, Memi[buf], npix) + else if (mtype == M_GTVAL) + call ableki (Memi[buf], mvalue, Memi[buf], npix) + + dflag = D_NONE + do i = 1, npix + if (Memi[buf+i-1] != 1) { + dflag = D_MIX + break + } + } else { + if (mtype == M_BOOLEAN || mtype == M_BADBITS) { + ; + } else if ((mtype == M_BADVAL && mvalue != 0) || + (mtype == M_NOVAL && mvalue != 0) || + (mtype == M_GOODVAL && mvalue == 0)) { + ; + } else if (mtype == M_LTVAL && mvalue > 0) { + ; + } else + dflag = D_NONE + } +end + + +# IC_MCLOSE1 -- Close mask by index. + +procedure ic_mclose1 (image, nimages) + +int image # Image index +int nimages # Number of images + +pointer pms, names, pm, fname +include "icombine.com" + +begin + if (icm == NULL) + return + + pms = ICM_PMS(icm) + names = ICM_NAMES(icm) + + if (project) { + pm = Memi[pms] + fname = Memi[names] + } else { + pm = Memi[pms+image-1] + fname = Memi[names+image-1] + } + + if (fname == NULL || pm == NULL) + return + if (Memc[fname] == EOS || pm == NULL) + return + + call pm_close (pm) + if (project) + Memi[pms] = NULL + else + Memi[pms+image-1] = NULL +end + + +# YT_PMLOAD -- This is like yt_mappm except it returns the mask pointer. + +pointer procedure yt_pmload (pmname, refim, match, mname, sz_mname) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer +char match[ARB] #I Match by physical coordinates? +char mname[ARB] #O Expanded mask name +int sz_mname #O Size of expanded mask name +pointer pm #R Pixel mask pointer + +int imstati() +pointer im, yt_mappm() +errchk yt_mappm + +begin + im = yt_mappm (pmname, refim, match, mname, sz_mname) + if (im != NULL) { + pm = imstati (im, IM_PMDES) + call imseti (im, IM_PMDES, NULL) + call imunmap (im) + } else + pm = NULL + return (pm) +end diff --git a/pkg/images/immatch/src/imcombine/src/icmedian.gx b/pkg/images/immatch/src/imcombine/src/icmedian.gx new file mode 100644 index 00000000..164140a1 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmedian.gx @@ -0,0 +1,246 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sird) +# IC_MEDIAN -- Median of lines + +procedure ic_median$t (d, n, npts, doblank, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +int doblank # Set blank values? +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, j1, j2, n1, lo, up, lo1, up1 +bool even +$if (datatype == silx) +real val1, val2, val3 +$else +PIXEL val1, val2, val3 +$endif +PIXEL temp, wtemp +$if (datatype == x) +real abs_temp +$endif + +include "../icombine.com" + +begin + # If no data return after possibly setting blank values. + if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + median[i]= blank + } + return + } + + # If the data were previously sorted then directly compute the median. + if (mclip) { + if (dflag == D_ALL) { + n1 = n[1] + j1 = n1 / 2 + 1 + j2 = n1 / 2 + even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) + do i = 1, npts { + k = i - 1 + if (even) { + val1 = Mem$t[d[j1]+k] + val2 = Mem$t[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mem$t[d[j1]+k] + } + return + } else { + # Check for negative n values. If found then there are + # pixels with no good values but with values we want to + # use as a substitute median. In this case ignore that + # the good pixels have been sorted. + do i = 1, npts { + if (n[i] < 0) + break + } + + if (n[i] >= 0) { + do i = 1, npts { + k = i - 1 + n1 = n[i] + if (n1 > 0) { + j1 = n1 / 2 + 1 + if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { + j2 = n1 / 2 + val1 = Mem$t[d[j1]+k] + val2 = Mem$t[d[j2]+k] + median[i] = (val1 + val2) / 2. + } else + median[i] = Mem$t[d[j1]+k] + } else if (doblank == YES) + median[i] = blank + } + return + } + } + } + + # Compute the median. + do i = 1, npts { + k = i - 1 + n1 = abs(n[i]) + + # If there are more than 3 points use Wirth algorithm. This + # is the same as vops$amed.gx except for an even number of + # points it selects the middle two and averages. + if (n1 > 3) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + + median[i] = Mem$t[d[j]+k] + + if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { + lo = 1 + up = n1 + j = max (lo, min (up, (up+1)/2)+1) + + while (lo < up) { + if (! (lo < up)) + break + + temp = Mem$t[d[j]+k]; lo1 = lo; up1 = up + $if (datatype == x) + abs_temp = abs (temp) + $endif + + repeat { + $if (datatype == x) + while (abs (Mem$t[d[lo1]+k]) < abs_temp) + $else + while (Mem$t[d[lo1]+k] < temp) + $endif + lo1 = lo1 + 1 + $if (datatype == x) + while (abs_temp < abs (Mem$t[d[up1]+k])) + $else + while (temp < Mem$t[d[up1]+k]) + $endif + up1 = up1 - 1 + if (lo1 <= up1) { + wtemp = Mem$t[d[lo1]+k] + Mem$t[d[lo1]+k] = Mem$t[d[up1]+k] + Mem$t[d[up1]+k] = wtemp + lo1 = lo1 + 1; up1 = up1 - 1 + } + } until (lo1 > up1) + + if (up1 < j) + lo = lo1 + if (j < lo1) + up = up1 + } + median[i] = (median[i] + Mem$t[d[j]+k]) / 2 + } + + # If 3 points find the median directly. + } else if (n1 == 3) { + $if (datatype == x) + val1 = abs (Mem$t[d[1]+k]) + val2 = abs (Mem$t[d[2]+k]) + val3 = abs (Mem$t[d[3]+k]) + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = Mem$t[d[2]+k] + else if (val1 < val3) # acb + median[i] = Mem$t[d[3]+k] + else # cab + median[i] = Mem$t[d[1]+k] + } else { + if (val2 > val3) # cba + median[i] = Mem$t[d[2]+k] + else if (val1 > val3) # bca + median[i] = Mem$t[d[3]+k] + else # bac + median[i] = Mem$t[d[1]+k] + } + $else + val1 = Mem$t[d[1]+k] + val2 = Mem$t[d[2]+k] + val3 = Mem$t[d[3]+k] + if (val1 < val2) { + if (val2 < val3) # abc + median[i] = val2 + else if (val1 < val3) # acb + median[i] = val3 + else # cab + median[i] = val1 + } else { + if (val2 > val3) # cba + median[i] = val2 + else if (val1 > val3) # bca + median[i] = val3 + else # bac + median[i] = val1 + } + $endif + + # If 2 points average. + } else if (n1 == 2) { + val1 = Mem$t[d[1]+k] + val2 = Mem$t[d[2]+k] + if (medtype == MEDAVG) + median[i] = (val1 + val2) / 2 + else + median[i] = min (val1, val2) + + # If 1 point return the value. + } else if (n1 == 1) + median[i] = Mem$t[d[1]+k] + + # If no points return with a possibly blank value. + else if (doblank == YES) + median[i] = blank + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icmm.gx b/pkg/images/immatch/src/imcombine/src/icmm.gx new file mode 100644 index 00000000..860cb512 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icmm.gx @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sird) +# IC_MM -- Reject a specified number of high and low pixels + +procedure ic_mm$t (d, m, n, npts) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line + +int n1, ncombine, npairs, nlow, nhigh, np +int i, i1, j, jmax, jmin +pointer k, kmax, kmin +PIXEL d1, d2, dmin, dmax + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + if (dflag == D_ALL) { + n1 = max (0, n[1]) + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = n1 - nlow - nhigh + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + do i = 1, npts { + i1 = i - 1 + n1 = max (0, n[i]) + if (dflag == D_MIX) { + nlow = flow * n1 + 0.001 + nhigh = fhigh * n1 + 0.001 + ncombine = max (ncombine, n1 - nlow - nhigh) + npairs = min (nlow, nhigh) + nlow = nlow - npairs + nhigh = nhigh - npairs + } + + # Reject the npairs low and high points. + do np = 1, npairs { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k + do j = 2, n1 { + d2 = d1 + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } else if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + j = n1 - 1 + if (keepids) { + if (jmax < j) { + if (jmin != j) { + Mem$t[kmax] = d2 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } else { + Mem$t[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } + if (jmin < j) { + if (jmax != n1) { + Mem$t[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } else { + Mem$t[kmin] = d2 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[j]+i1] + Memi[m[j]+i1] = k + } + } + } else { + if (jmax < j) { + if (jmin != j) + Mem$t[kmax] = d2 + else + Mem$t[kmax] = d1 + } + if (jmin < j) { + if (jmax != n1) + Mem$t[kmin] = d1 + else + Mem$t[kmin] = d2 + } + } + n1 = n1 - 2 + } + + # Reject the excess low points. + do np = 1, nlow { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmin = d1; jmin = 1; kmin = k + do j = 2, n1 { + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 < dmin) { + dmin = d1; jmin = j; kmin = k + } + } + if (keepids) { + if (jmin < n1) { + Mem$t[kmin] = d1 + k = Memi[m[jmin]+i1] + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmin < n1) + Mem$t[kmin] = d1 + } + n1 = n1 - 1 + } + + # Reject the excess high points. + do np = 1, nhigh { + k = d[1] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + dmax = d1; jmax = 1; kmax = k + do j = 2, n1 { + k = d[j] + i1 + $if (datatype == x) + d1 = abs (Mem$t[k]) + $else + d1 = Mem$t[k] + $endif + if (d1 > dmax) { + dmax = d1; jmax = j; kmax = k + } + } + if (keepids) { + if (jmax < n1) { + Mem$t[kmax] = d1 + k = Memi[m[jmax]+i1] + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + Memi[m[n1]+i1] = k + } + } else { + if (jmax < n1) + Mem$t[kmax] = d1 + } + n1 = n1 - 1 + } + n[i] = n1 + } + + if (dflag == D_ALL && npairs + nlow + nhigh > 0) + dflag = D_MIX +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icnmodel.gx b/pkg/images/immatch/src/imcombine/src/icnmodel.gx new file mode 100644 index 00000000..0e020dc9 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icnmodel.gx @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_NMODEL -- Compute the quadrature average (or summed) noise model. +# Options include a weighted average/sum. + +procedure ic_nmodel$t (d, m, n, nm, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real nm[3,nimages] # Noise model parameters +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +real val, wt, sumwt +$if (datatype == sil) +real sum, zero +data zero /0.0/ +$else +PIXEL sum, zero +data zero /0$f/ +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + do j = 2, n[i] { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n[i] { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + wt = wts[Memi[m[1]+k]] + sum = val * wt**2 + sumwt = wt + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + wt = wts[Memi[m[j]+k]] + sum = sum + val * wt**2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = Mem$t[d[1]+k]**2 + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + + (val*nm[3,j])**2 + sum = sum + val + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = max (zero, Mem$t[d[1]+k]) + val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 + sum = val + do j = 2, n1 { + val = max (zero, Mem$t[d[j]+k]) + val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 + sum = sum + val + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icomb.gx b/pkg/images/immatch/src/imcombine/src/icomb.gx new file mode 100644 index 00000000..ae489158 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icomb.gx @@ -0,0 +1,761 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "../icombine.h" + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include + + +# ICOMBINE -- Combine images +# +# The memory and open file descriptor limits are checked and an attempt +# to recover is made either by setting the image pixel files to be +# closed after I/O or by notifying the calling program that memory +# ran out and the IMIO buffer size should be reduced. After the checks +# a procedure for the selected combine option is called. +# Because there may be several failure modes when reaching the file +# limits we first assume an error is due to the file limit, except for +# out of memory, and close some pixel files. If the error then repeats +# on accessing the pixels the error is passed back. + +$for (sird) +procedure icombine$t (in, out, scales, zeros, wts, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +real scales[nimages] # Scales +real zeros[nimages] # Zeros +real wts[nimages] # Weights +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, k, npts, fd, stropen(), xt_imgnl$t() +pointer sp, d, id, n, m, lflag, v, dbuf +pointer im, buf, xt_opix(), impl1i() +errchk stropen, xt_cpix, xt_opix, xt_imgnl$t, impl1i, ic_combine$t +$if (datatype == sil) +pointer impl1r() +errchk impl1r +$else +pointer impl1$t() +errchk impl1$t +$endif + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + call salloc (dbuf, nimages, TY_POINTER) + call salloc (d, nimages, TY_POINTER) + call salloc (id, nimages, TY_POINTER) + call salloc (n, npts, TY_INT) + call salloc (m, nimages, TY_POINTER) + call salloc (lflag, nimages, TY_INT) + call salloc (v, IM_MAXDIM, TY_LONG) + call amovki (D_ALL, Memi[lflag], nimages) + call amovkl (1, Meml[v], IM_MAXDIM) + + # If not aligned or growing create data buffers of output length + # otherwise use the IMIO buffers. + + if (!aligned || grow >= 1.) { + do i = 1, nimages { + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) + } + } else { + do i = 1, nimages { + im = xt_opix (in[i], i, 1) + if (im != in[i]) { + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) + } + } + call amovki (NULL, Memi[dbuf], nimages) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFFRAC, 0) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + } else { + # Reserve FD for string operations. + fd = stropen (str, 1, NEW_FILE) + + # Do I/O to the images. + do i = 1, 6 { + if (out[i] != NULL) { + call imseti (out[i], IM_BUFFRAC, 0) + call imseti (out[i], IM_BUFSIZE, bufsize) + } + } + $if (datatype == sil) + buf = impl1r (out[1]) + call aclrr (Memr[buf], npts) + if (out[3] != NULL) { + buf = impl1r (out[3]) + call aclrr (Memr[buf], npts) + } + $else + buf = impl1$t (out[1]) + call aclr$t (Mem$t[buf], npts) + if (out[3] != NULL) { + buf = impl1$t (out[3]) + call aclr$t (Mem$t[buf], npts) + } + $endif + if (out[2] != NULL) { + buf = impl1i (out[2]) + call aclri (Memi[buf], npts) + } + if (out[4] != NULL) { + buf = impl1i (out[4]) + call aclri (Memi[buf], npts) + } + if (out[5] != NULL) { + buf = impl1i (out[5]) + call aclri (Memi[buf], npts) + } + if (out[6] != NULL) { + buf = impl1i (out[6]) + call aclri (Memi[buf], npts) + } + + # Do I/O for first input image line. + if (!project) { + do i = 1, nimages { + call xt_imseti (i, "bufsize", bufsize) + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + call xt_cpix (i) + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + call xt_cpix (i) + } + + do i = 1, nimages { + j = max (0, offsets[i,1]) + k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) + if (k - j < 1) + next + j = 1 - offsets[i,2] + if (j < 1 || j > IM_LEN(in[i],2)) + next + iferr { + Meml[v+1] = j + j = xt_imgnl$t (in[i], i, buf, Meml[v], 1) + } then { + call imseti (im, IM_PIXFD, NULL) + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + } + } + + call strclose (fd) + } + + call ic_combine$t (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], + Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) +end + + +# IC_COMBINE -- Combine images. + +procedure ic_combine$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, wts, nimages, npts) + +pointer in[nimages] # Input images +pointer out[ARB] # Output image +pointer dbuf[nimages] # Data buffers for nonaligned images +pointer d[nimages] # Data pointers +pointer id[nimages] # Image index ID pointers +int n[npts] # Number of good pixels +pointer m[nimages] # Mask pointers +int lflag[nimages] # Line flags +int offsets[nimages,ARB] # Input image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero offset factors +real wts[nimages] # Combining weights +int nimages # Number of input images +int npts # Number of points per output line + +int i, ext, ctor(), errcode() +real r, imgetr() +pointer sp, fname, imname, v1, v2, v3, work +pointer outdata, buf, nmod, nm, pms +pointer immap(), impnli() +$if (datatype == sil) +pointer impnlr(), imgnlr() +$else +pointer impnl$t(), imgnl$t +$endif +errchk immap, ic_scale, imgetr, ic_grow, ic_grow$t, ic_rmasks, ic_emask +errchk ic_gdata$t + +include "../icombine.com" +data ext/0/ + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (v3, IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + + call ic_scale (in, out, offsets, scales, zeros, wts, nimages) + + # Set combine parameters + switch (combine) { + case AVERAGE, SUM, QUAD, NMODEL: + if (dowts) + keepids = true + else + keepids = false + case MEDIAN: + dowts = false + keepids = false + } + docombine = true + + # Get noise model parameters. + if (combine==NMODEL) { + call salloc (nmod, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nmod+3*(i-1)+1] = r * scales[i] + Memr[nmod+3*(i-1)] = + max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, + 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nmod+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nmod+3*(i-1)+2] = r + } + } + } + + # Set rejection algorithm specific parameters + switch (reject) { + case CCDCLIP, CRREJECT: + call salloc (nm, 3*nimages, TY_REAL) + i = 1 + if (ctor (Memc[rdnoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)] = r + } else { + do i = 1, nimages + Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) + } + i = 1 + if (ctor (Memc[gain], i, r) > 0) { + do i = 1, nimages { + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[gain]) + Memr[nm+3*(i-1)+1] = r + Memr[nm+3*(i-1)] = + max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) + } + } + i = 1 + if (ctor (Memc[snoise], i, r) > 0) { + do i = 1, nimages + Memr[nm+3*(i-1)+2] = r + } else { + do i = 1, nimages { + r = imgetr (in[i], Memc[snoise]) + Memr[nm+3*(i-1)+2] = r + } + } + if (!keepids) { + if (doscale1) + keepids = true + else { + do i = 2, nimages { + if (Memr[nm+3*(i-1)] != Memr[nm] || + Memr[nm+3*(i-1)+1] != Memr[nm+1] || + Memr[nm+3*(i-1)+2] != Memr[nm+2]) { + keepids = true + break + } + } + } + } + if (reject == CRREJECT) + lsigma = MAX_REAL + case MINMAX: + mclip = false + case PCLIP: + mclip = true + case AVSIGCLIP, SIGCLIP: + if (doscale1) + keepids = true + case NONE: + mclip = false + } + + if (out[4] != NULL) + keepids = true + + if (out[6] != NULL) { + keepids = true + call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) + } + + if (grow >= 1.) { + keepids = true + call salloc (work, npts * nimages, TY_INT) + } + pms = NULL + + if (keepids) { + do i = 1, nimages + call salloc (id[i], npts, TY_INT) + } + +# This idea turns out to has a problem with masks are used with wcs offsets. +# the matching of masks to images based on WCS requires access to the WCS +# of the images. For now we drop this idea but maybe a way can be identified +# to know when this is not going to be needed. +# # Reduce header memory use. +# do i = 1, nimages +# call xt_minhdr (i) + + $if (datatype == sil) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + else + call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Memr[outdata]) + case MINMAX: + call ic_mm$t (d, id, n, npts) + case PCLIP: + call ic_pclip$t (d, id, n, nimages, npts, Memr[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + else + call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, + Memr[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + else + call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Memr[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, NO, Memr[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + YES, YES, Memr[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Memr[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $else + while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + switch (reject) { + case CCDCLIP, CRREJECT: + if (mclip) + call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Mem$t[outdata]) + else + call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], + nimages, npts, Mem$t[outdata]) + case MINMAX: + call ic_mm$t (d, id, n, npts) + case PCLIP: + call ic_pclip$t (d, id, n, nimages, npts, Mem$t[outdata]) + case SIGCLIP: + if (mclip) + call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, + Mem$t[outdata]) + else + call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, + Mem$t[outdata]) + case AVSIGCLIP: + if (mclip) + call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Mem$t[outdata]) + else + call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, + npts, Mem$t[outdata]) + } + + if (pms == NULL || nkeep > 0) { + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, YES, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, YES, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + YES, NO, Mem$t[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + YES, YES, Mem$t[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, YES, YES, Mem$t[outdata]) + } + } + } + + if (grow >= 1.) + call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, + pms) + + if (pms == NULL) { + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnl$t (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], + Mem$t[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + } + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + if (pms != NULL) { + if (nkeep > 0) { + call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call imunmap (out[1]) + iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { + switch (errcode()) { + case SYS_FXFOPNOEXTNV: + call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) + ext = ext + 1 + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext) + iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { + buf = NULL + ext = 0 + } + repeat { + call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") + call pargstr (Memc[fname]) + call pargi (ext+1) + iferr (outdata = immap (Memc[imname],READ_WRITE,0)) + break + if (buf != NULL) + call imunmap (buf) + buf = outdata + ext = ext + 1 + } + default: + call erract (EA_ERROR) + } + } + out[1] = buf + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + call amovkl (long(1), Meml[v3], IM_MAXDIM) + $if (datatype == sil) + while (impnlr (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnlr (out[1], buf, Meml[v1]) == EOF) + ; + call amovr (Memr[buf], Memr[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Memr[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, NO, Memr[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + NO, YES, Memr[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Memr[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnlr (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], + Memr[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $else + while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { + call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, + scales, zeros, nimages, npts, Meml[v2], Meml[v3]) + + call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, + pms) + + if (nkeep > 0) { + do i = 1, npts { + if (n[i] < nkeep) { + Meml[v1+1] = Meml[v1+1] - 1 + if (imgnl$t (out[1], buf, Meml[v1]) == EOF) + ; + call amov$t (Mem$t[buf], Mem$t[outdata], npts) + break + } + } + } + + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, YES, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, NO, Mem$t[outdata]) + case SUM: + call ic_average$t (d, id, n, wts, nimages, npts, + NO, NO, Mem$t[outdata]) + case QUAD: + call ic_quad$t (d, id, n, wts, nimages, npts, + NO, YES, Mem$t[outdata]) + case NMODEL: + call ic_nmodel$t (d, id, n, Memr[nmod], wts, + nimages, npts, NO, YES, Mem$t[outdata]) + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + do i = 1, npts { + if (n[i] > 0) + Memi[buf] = 0 + else if (n[i] == 0) + Memi[buf] = 1 + else + Memi[buf] = 2 + buf = buf + 1 + } + } + + if (out[3] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnl$t (out[3], buf, Meml[v1]) + call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], + Mem$t[buf]) + } + + if (out[4] != NULL) + call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) + + if (out[5] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[5], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + if (out[6] != NULL) + call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) + + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + do i = 1, nimages + call pm_close (Memi[pms+i-1]) + call mfree (pms, TY_POINTER) + } + + call sfree (sp) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icombine.com b/pkg/images/immatch/src/imcombine/src/icombine.com new file mode 100644 index 00000000..55ad308b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.com @@ -0,0 +1,45 @@ +# ICOMBINE Common + +int combine # Combine algorithm +int medtype # Median type +int reject # Rejection algorithm +bool project # Combine across the highest dimension? +real blank # Blank value +pointer expkeyword # Exposure time keyword +pointer statsec # Statistics section +pointer rdnoise # CCD read noise +pointer gain # CCD gain +pointer snoise # CCD sensitivity noise +real lthresh # Low threshold +real hthresh # High threshold +int nkeep # Minimum to keep +real lsigma # Low sigma cutoff +real hsigma # High sigma cutoff +real pclip # Number or fraction of pixels from median +real flow # Fraction of low pixels to reject +real fhigh # Fraction of high pixels to reject +real grow # Grow radius +bool mclip # Use median in sigma clipping? +real sigscale # Sigma scaling tolerance +int logfd # Log file descriptor + +# These flags allow special conditions to be optimized. + +int dflag # Data flag (D_ALL, D_NONE, D_MIX) +bool aligned # Are the images aligned? +bool doscale # Do the images have to be scaled? +bool doscale1 # Do the sigma calculations have to be scaled? +bool dothresh # Check pixels outside specified thresholds? +bool dowts # Does the final average have to be weighted? +bool keepids # Keep track of the image indices? +bool docombine # Call the combine procedure? +bool sort # Sort data? +bool verbose # Verbose? + +pointer icm # Mask data structure + +common /imccom/ combine, medtype, reject, blank, expkeyword, statsec, rdnoise, + gain, snoise, lsigma, hsigma, lthresh, hthresh, nkeep, + pclip, flow, fhigh, grow, logfd, dflag, sigscale, project, + mclip, aligned, doscale, doscale1, dothresh, dowts, + keepids, docombine, sort, verbose, icm diff --git a/pkg/images/immatch/src/imcombine/src/icombine.h b/pkg/images/immatch/src/imcombine/src/icombine.h new file mode 100644 index 00000000..51f60887 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.h @@ -0,0 +1,63 @@ +# ICOMBINE Definitions + +# Memory management parameters; +define MAXMEMORY 500000000 # maximum memory +define FUDGE 0.8 # fudge factor + +# Rejection options: +define REJECT "|none|ccdclip|crreject|minmax|pclip|sigclip|avsigclip|" +define NONE 1 # No rejection algorithm +define CCDCLIP 2 # CCD noise function clipping +define CRREJECT 3 # CCD noise function clipping +define MINMAX 4 # Minmax rejection +define PCLIP 5 # Percentile clip +define SIGCLIP 6 # Sigma clip +define AVSIGCLIP 7 # Sigma clip with average poisson sigma + +# Combine options: +define COMBINE "|average|median|lmedian|sum|quadrature|nmodel|" +define AVERAGE 1 +define MEDIAN 2 +define LMEDIAN 3 +define SUM 4 +define QUAD 5 +define NMODEL 6 + +# Median types: +define MEDAVG 1 # Central average for even N +define MEDLOW 2 # Lower value for even N + +# Scaling options: +define STYPES "|none|mode|median|mean|exposure|" +define ZTYPES "|none|mode|median|mean|" +define WTYPES "|none|mode|median|mean|exposure|" +define S_NONE 1 +define S_MODE 2 +define S_MEDIAN 3 +define S_MEAN 4 +define S_EXPOSURE 5 +define S_FILE 6 +define S_KEYWORD 7 +define S_SECTION "|input|output|overlap|" +define S_INPUT 1 +define S_OUTPUT 2 +define S_OVERLAP 3 + +# Mask options +define MASKTYPES "|none|goodvalue|badvalue|goodbits|badbits|novalue|" +define M_NONE 1 # Don't use mask images +define M_GOODVAL 2 # Value selecting good pixels +define M_BADVAL 3 # Value selecting bad pixels +define M_GOODBITS 4 # Bits selecting good pixels +define M_BADBITS 5 # Bits selecting bad pixels +define M_NOVAL 6 # Value selecting no value (good = 0) +define M_LTVAL 7 # Values less than specified are good +define M_GTVAL 8 # Values greater than specified are good +define M_BOOLEAN -1 # Ignore mask values + +# Data flag +define D_ALL 0 # All pixels are good +define D_NONE 1 # All pixels are bad or rejected +define D_MIX 2 # Mixture of good and bad pixels + +define TOL 0.001 # Tolerance for equal residuals diff --git a/pkg/images/immatch/src/imcombine/src/icombine.x b/pkg/images/immatch/src/imcombine/src/icombine.x new file mode 100644 index 00000000..b6e5ddd4 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icombine.x @@ -0,0 +1,520 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "icombine.h" + + +# ICOMBINE -- Combine input list or image. +# This procedure maps the images, sets the output dimensions and datatype, +# opens the logfile, and sets IMIO parameters. It attempts to adjust +# buffer sizes and memory requirements for maximum efficiency. + +procedure icombine (list, output, headers, bmask, rmask, nrmask, emask, + sigma, logfile, scales, zeros, wts, stack, delete, listonly) + +int list #I List of input images +char output[ARB] #I Output image +char headers[ARB] #I Output header rootname +char bmask[ARB] #I Bad pixel mask +char rmask[ARB] #I Rejection mask +char nrmask[ARB] #I Nreject mask +char emask[ARB] #I Exposure mask +char sigma[ARB] #I Sigma image (optional) +char logfile[ARB] #I Logfile (optional) +real scales[ARB] #I Scale factors +real zeros[ARB] #I Offset factors +real wts[ARB] #I Weights +int stack #I Stack input images? +int delete #I Delete input images? +int listonly #I List images to combine? + +bool proj +char input[SZ_FNAME], errstr[SZ_LINE] +int i, j, nimages, intype, bufsize, oldsize, stack1, err, retry +int maxsize, maxmemory, memory +pointer sp, im, in1, in, out[6], offsets, key, tmp, bpmstack + +char clgetc() +int clgwrd(), imtlen(), imtgetim(), imtrgetim(), getdatatype(), envgeti() +int begmem(), errget(), open(), ty_max(), sizeof(), strmatch() +pointer immap(), xt_immap(), ic_pmmap() +errchk ic_imstack, immap, imunmap, xt_immap, ic_pmmap, ic_setout + +include "icombine.com" + +define retry_ 98 +define err_ 99 + +begin + if (listonly == YES) { + # Write the output list. + if (output[1] == EOS) { + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + i = strmatch (input, "[0]") - 3 + if (i > 0) + call strcpy (input[i+3], input[i], SZ_FNAME) + call printf ("%s\n") + call pargstr (input) + } + } else { + call sprintf (errstr, SZ_LINE, "%s.list") + call pargstr (output) + iferr (logfd = open (errstr, APPEND, TEXT_FILE)) + call erract (EA_WARN) + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + i = strmatch (input, "[0]") - 3 + if (i > 0) + call strcpy (input[i+3], input[i], SZ_FNAME) + call printf ("%s -> %s\n") + call pargstr (input) + call pargstr (errstr) + call fprintf (logfd, "%s\n") + call pargstr (input) + } + call close (logfd) + } + return + } + + nimages = imtlen (list) + if (nimages == 0) + call error (1, "No images to combine") + + if (project) { + if (imtgetim (list, input, SZ_FNAME) == EOF) + call error (1, "No image to project") + } + + bufsize = 0 +# if (nimages > LAST_FD - 15) +# stack1 = YES +# else + stack1 = stack + + retry = 0 + +retry_ + iferr { + call smark (sp) + call salloc (in, 1, TY_POINTER) + + nimages = 0 + in1 = NULL; Memi[in] = NULL; logfd = NULL + out[1] = NULL; out[2] = NULL; out[3] = NULL + out[4] = NULL; out[5] = NULL; out[6] = NULL + + # Stack the input images. + if (stack1 == YES) { + proj = project + project = true + call salloc (bpmstack, SZ_FNAME, TY_CHAR) + i = clgwrd ("masktype", Memc[bpmstack], SZ_FNAME, MASKTYPES) + if (i == M_NONE) + Memc[bpmstack] = EOS + else { + call mktemp ("tmp", Memc[bpmstack], SZ_FNAME) + call strcat (".pl", Memc[bpmstack], SZ_FNAME) + } + call mktemp ("tmp", input, SZ_FNAME) + call imtrew (list) + call ic_imstack (list, input, Memc[bpmstack]) + } + + # Open the input image(s). + if (project) { + tmp = immap (input, READ_ONLY, 0); out[1] = tmp + if (IM_NDIM(out[1]) == 1) + call error (1, "Can't project one dimensional images") + nimages = IM_LEN(out[1],IM_NDIM(out[1])) + call salloc (in, nimages, TY_POINTER) + call amovki (out[1], Memi[in], nimages) + } else { + call salloc (in, imtlen(list), TY_POINTER) + call amovki (NULL, Memi[in], imtlen(list)) + call imtrew (list) + while (imtgetim (list, input, SZ_FNAME)!=EOF) { + nimages = nimages + 1 + tmp = xt_immap (input, READ_ONLY, 0, nimages, retry) + Memi[in+nimages-1] = tmp + } + + # Check sizes and set I/O option. + intype = 0 + tmp = Memi[in] + do i = 2, nimages { + do j = 1, IM_NDIM(tmp) { + if (IM_LEN(tmp,j) != IM_LEN(Memi[in+i-1],j)) + intype = 1 + } + if (intype == 1) + break + } + if (intype == 1) + call xt_imseti (0, "option", intype) + } + + # Check if there are no images. + if (nimages == 0) + call error (1, "No images to combine") + + # Convert the pclip parameter to a number of pixels rather than + # a fraction. This number stays constant even if pixels are + # rejected. The number of low and high pixel rejected, however, + # are converted to a fraction of the valid pixels. + + if (reject == PCLIP) { + i = nimages / 2. + if (abs (pclip) < 1.) + pclip = pclip * i + if (pclip < 0.) + pclip = min (-1, max (-i, int (pclip))) + else + pclip = max (1, min (i, int (pclip))) + } + + if (reject == MINMAX) { + if (flow >= 1) + flow = flow / nimages + if (fhigh >= 1) + fhigh = fhigh / nimages + i = flow * nimages + j = fhigh * nimages + if (i + j == 0) + reject = NONE + else if (i + j >= nimages) + call error (1, "Bad minmax rejection parameters") + } + + # Map the output image and set dimensions and offsets. + if (stack1 == YES) { + call imtrew (list) + i = imtgetim (list, errstr, SZ_LINE) + in1 = immap (errstr, READ_ONLY, 0) + tmp = immap (output, NEW_COPY, in1); out[1] = tmp + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 1, nimages { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + if (Memc[bpmstack] != EOS) { + call sprintf (Memc[key], SZ_FNAME, "bpm%04d") + call pargi (i) + iferr (call imdelf (out[1], Memc[key])) + ; + } + } + } else { + tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp + if (project) { + IM_LEN(out[1],IM_NDIM(out[1])) = 1 + IM_NDIM(out[1]) = IM_NDIM(out[1]) - 1 + } + } + call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT) + iferr (call ic_setout (Memi[in], out, Memi[offsets], nimages)) { + call erract (EA_WARN) + call error (1, "Can't set output geometry") + } + call ic_hdr (Memi[in], out, nimages) + iferr (call imdelf (out, "BPM")) + ; + + # Determine the highest precedence datatype and set output datatype. + intype = IM_PIXTYPE(Memi[in]) + do i = 2, nimages + intype = ty_max (intype, IM_PIXTYPE(Memi[in+i-1])) + IM_PIXTYPE(out[1]) = getdatatype (clgetc ("outtype")) + if (IM_PIXTYPE(out[1]) == ERR) + IM_PIXTYPE(out[1]) = intype + + # Open rejection masks + if (rmask[1] != EOS) { + tmp = ic_pmmap (rmask, NEW_COPY, out[1]); out[4] = tmp + IM_NDIM(out[4]) = IM_NDIM(out[4]) + 1 + IM_LEN(out[4],IM_NDIM(out[4])) = nimages + if (!project) { + if (key == NULL) + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 100, nimages { + j = imtrgetim (list, i, input, SZ_FNAME) + if (i < 999) + call sprintf (Memc[key], SZ_FNAME, "imcmb%d") + else if (i < 9999) + call sprintf (Memc[key], SZ_FNAME, "imcm%d") + else + call sprintf (Memc[key], SZ_FNAME, "imc%d") + call pargi (i) + call imastr (out[4], Memc[key], input) + } + } + } else + out[4] = NULL + + # Open bad pixel pixel list file if given. + if (bmask[1] != EOS) { + tmp = ic_pmmap (bmask, NEW_COPY, out[1]); out[2] = tmp + } else + out[2] = NULL + + # Open nreject pixel list file if given. + if (nrmask[1] != EOS) { + tmp = ic_pmmap (nrmask, NEW_COPY, out[1]); out[5] = tmp + } else + out[5] = NULL + + # Open exposure mask if given. + if (emask[1] != EOS) { + tmp = ic_pmmap (emask, NEW_COPY, out[1]); out[6] = tmp + } else + out[6] = NULL + + # Open the sigma image if given. + if (sigma[1] != EOS) { + tmp = immap (sigma, NEW_COPY, out[1]); out[3] = tmp + IM_PIXTYPE(out[3]) = ty_max (TY_REAL, IM_PIXTYPE(out[1])) + call sprintf (IM_TITLE(out[3]), SZ_IMTITLE, + "Combine sigma images for %s") + call pargstr (output) + } else + out[3] = NULL + + # Open masks. + call ic_mopen (Memi[in], out, nimages, Memi[offsets], + min(retry,1)) + + # Open the log file. + logfd = NULL + if (logfile[1] != EOS) { + iferr (logfd = open (logfile, APPEND, TEXT_FILE)) { + logfd = NULL + call erract (EA_WARN) + } + } + + if (bufsize == 0) { + # Set initial IMIO buffer size based on the number of images + # and maximum amount of working memory available. The buffer + # size may be adjusted later if the task runs out of memory. + # The FUDGE factor is used to allow for the size of the + # program, memory allocator inefficiencies, and any other + # memory requirements besides IMIO. + + iferr (maxmemory = envgeti ("imcombine_maxmemory")) + maxmemory = MAXMEMORY + memory = begmem (0, oldsize, maxsize) + memory = min (memory, maxsize, maxmemory) + bufsize = FUDGE * memory / (nimages + 1) / sizeof (intype) + } + + # Combine the images. If an out of memory error occurs close all + # images and files, divide the IMIO buffer size in half and try + # again. + + switch (ty_max (intype, IM_PIXTYPE(out[1]))) { + case TY_SHORT: + call icombines (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_USHORT, TY_INT, TY_LONG: + call icombinei (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_DOUBLE: + call icombined (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + case TY_COMPLEX: + call error (1, "Complex images not allowed") + default: + call icombiner (Memi[in], out, scales, zeros, + wts, Memi[offsets], nimages, bufsize) + } + } then { + err = errget (errstr, SZ_LINE) + if (err == SYS_IKIOPIX && nimages < 250) + err = SYS_MFULL + call ic_mclose (nimages) + if (!project) { + do j = 2, nimages { + if (Memi[in+j-1] != NULL) + call xt_imunmap (Memi[in+j-1], j) + } + } + if (out[2] != NULL) { + iferr (call imunmap (out[2])) + ; + iferr (call imdelete (bmask)) + ; + } + if (out[3] != NULL) { + iferr (call imunmap (out[3])) + ; + iferr (call imdelete (sigma)) + ; + } + if (out[4] != NULL) { + iferr (call imunmap (out[4])) + ; + iferr (call imdelete (rmask)) + ; + } + if (out[5] != NULL) { + iferr (call imunmap (out[5])) + ; + iferr (call imdelete (nrmask)) + ; + } + if (out[6] != NULL) { + iferr (call imunmap (out[6])) + ; + iferr (call imdelete (emask)) + ; + } + if (out[1] != NULL) { + iferr (call imunmap (out[1])) + ; + iferr (call imdelete (output)) + ; + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (logfd != NULL) + call close (logfd) + + switch (err) { + case SYS_MFULL: + if (project) + goto err_ + + if (bufsize < 10000 && retry > 2) { + call strcat ("- Maybe min_lenuserarea is too large", + errstr, SZ_LINE) + goto err_ + } + + bufsize = bufsize / 2 + retry = retry + 1 + call sfree (sp) + goto retry_ + case SYS_FTOOMANYFILES, SYS_IKIOPEN, SYS_IKIOPIX, SYS_FOPEN, SYS_FWTNOACC: + if (project) + goto err_ + stack1 = YES + call sfree (sp) + goto retry_ + default: +err_ + if (stack1 == YES) { + iferr (call imdelete (input)) + ; + if (Memc[bpmstack] != EOS) { + iferr (call imdelete (Memc[bpmstack])) + ; + } + } + call fixmem (oldsize) + while (imtgetim (list, input, SZ_FNAME)!=EOF) + ; + call sfree (sp) + call error (err, errstr) + } + } + + # Unmap all the images, close the log file, and restore memory. + if (out[2] != NULL) + iferr (call imunmap (out[2])) + call erract (EA_WARN) + if (out[3] != NULL) + iferr (call imunmap (out[3])) + call erract (EA_WARN) + if (out[4] != NULL) { + # Close the output first so that there is no confusion with + # inheriting the output header. Then update the WCS for the + # extra dimension. Note that this may not be correct with + # axis reduced WCS. + iferr { + call imunmap (out[4]) + out[4] = immap (rmask, READ_WRITE, 0) + i = IM_NDIM(out[4]) + call imaddi (out[4], "WCSDIM", i) + call sprintf (errstr, SZ_LINE, "LTM%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call sprintf (errstr, SZ_LINE, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (out[4], errstr, 1.) + call imunmap (out[4]) + } then + call erract (EA_WARN) + } + if (out[5] != NULL) + iferr (call imunmap (out[5])) + call erract (EA_WARN) + if (out[6] != NULL) + iferr (call imunmap (out[6])) + call erract (EA_WARN) + if (out[1] != NULL) { + call imunmap (out[1]) + if (headers[1] != EOS) { + # Write input headers to a multiextension file if desired. + # This might be the same as the output image. + iferr { + do i = 1, nimages { + im = Memi[in+i-1] + call imstats (im, IM_IMAGENAME, input, SZ_FNAME) + if (strmatch (headers, ".fits$") == 0) { + call sprintf (errstr, SZ_LINE, "%s.fits[append]") + call pargstr (headers) + } else { + call sprintf (errstr, SZ_LINE, "%s[append]") + call pargstr (headers) + } + tmp = immap (errstr, NEW_COPY, im) + IM_NDIM(tmp) = 0 + do j = 1, IM_NDIM(im) { + call sprintf (errstr, SZ_LINE, "AXLEN%d") + call pargi (j) + call imaddi (tmp, errstr, IM_LEN(im,j)) + } + call imastr (tmp, "INIMAGE", input) + call imastr (tmp, "OUTIMAGE", output) + call imastr (tmp, "EXTNAME", input) + call imunmap (tmp) + } + if (logfd != NULL) { + call eprintf (" Headers = %s\n") + call pargstr (headers) + } + } then + call erract (EA_WARN) + } + } + if (!project) { + do i = 2, nimages { + if (Memi[in+i-1] != NULL) + call xt_imunmap (Memi[in+i-1], i) + } + } + if (Memi[in] != NULL) + call xt_imunmap (Memi[in], 1) + if (in1 != NULL) + call imunmap (in1) + if (stack1 == YES) { + call imdelete (input) + if (Memc[bpmstack] != EOS) + call imdelete (Memc[bpmstack]) + project = proj + } + if (logfd != NULL) + call close (logfd) + call ic_mclose (nimages) + call fixmem (oldsize) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icpclip.gx b/pkg/images/immatch/src/imcombine/src/icpclip.gx new file mode 100644 index 00000000..628dca0d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icpclip.gx @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Minimum number for clipping + +$for (sird) +# IC_PCLIP -- Percentile clip +# +# 1) Find the median +# 2) Find the pixel which is the specified order index away +# 3) Use the data value difference as a sigma and apply clipping +# 4) Since the median is known return it so it does not have to be recomputed + +procedure ic_pclip$t (d, m, n, nimages, npts, median) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of input images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep +bool even, fp_equalr() +real sigma, r, s, t +pointer sp, resid, mp1, mp2 +$if (datatype == sil) +real med +$else +PIXEL med +$endif + +include "../icombine.com" + +begin + # There must be at least MINCLIP and more than nkeep pixels. + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + + # Set sign of pclip parameter + if (pclip < 0) + t = -1. + else + t = 1. + + # If there are no rejected pixels compute certain parameters once. + if (dflag == D_ALL) { + n1 = max (0, n[1]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0.) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + nin = n1 + } + + # Now apply clipping. + do i = 1, npts { + # Compute median. + if (dflag == D_MIX) { + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + if (n1 == 0) { + if (combine == MEDIAN) + median[i] = blank + next + } + n2 = 1 + n1 / 2 + even = (mod (n1, 2) == 0) + if (pclip < 0) { + if (even) + n3 = max (1, nint (n2 - 1 + pclip)) + else + n3 = max (1, nint (n2 + pclip)) + } else + n3 = min (n1, nint (n2 + pclip)) + } + + j = i - 1 + if (even) { + med = Mem$t[d[n2-1]+j] + med = (med + Mem$t[d[n2]+j]) / 2. + } else + med = Mem$t[d[n2]+j] + + if (n1 < max (MINCLIP, maxkeep+1)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Define sigma for clipping + sigma = t * (Mem$t[d[n3]+j] - med) + if (fp_equalr (sigma, 0.)) { + if (combine == MEDIAN) + median[i] = med + next + } + + # Reject pixels and save residuals. + # Check if any pixels are clipped. + # If so recompute the median and reset the number of good pixels. + # Only reorder if needed. + + for (nl=1; nl<=n1; nl=nl+1) { + r = (med - Mem$t[d[nl]+j]) / sigma + if (r < lsigma) + break + Memr[resid+nl] = r + } + for (nh=n1; nh>=1; nh=nh-1) { + r = (Mem$t[d[nh]+j] - med) / sigma + if (r < hsigma) + break + Memr[resid+nh] = r + } + n4 = nh - nl + 1 + + # If too many pixels are rejected add some back in. + # All pixels with the same residual are added. + while (n4 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n4 = nh - nl + 1 + } + + # If any pixels are rejected recompute the median. + if (nl > 1 || nh < n1) { + n5 = nl + n4 / 2 + if (mod (n4, 2) == 0) { + med = Mem$t[d[n5-1]+j] + med = (med + Mem$t[d[n5]+j]) / 2. + } else + med = Mem$t[d[n5]+j] + n[i] = n4 + } + if (combine == MEDIAN) + median[i] = med + + # Reorder if pixels only if necessary. + if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+j] = Mem$t[d[k]+j] + if (grow >= 1.) { + mp1 = m[l] + j + mp2 = m[k] + j + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+j] = Memi[m[k]+j] + k = k + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+j] = Mem$t[d[k]+j] + k = k + 1 + } + } + } + } + + # Check if data flag needs to be reset for rejected pixels. + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag whether the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icpmmap.x b/pkg/images/immatch/src/imcombine/src/icpmmap.x new file mode 100644 index 00000000..1afeedd7 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icpmmap.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IC_PMMAP -- Map pixel mask. + +pointer procedure ic_pmmap (fname, mode, refim) + +char fname[ARB] # Mask name +int mode # Image mode +pointer refim # Reference image +pointer pm # IMIO pointer (returned) + +int i, fnextn() +pointer sp, extn, immap() +bool streq() + +begin + call smark (sp) + call salloc (extn, SZ_FNAME, TY_CHAR) + + i = fnextn (fname, Memc[extn], SZ_FNAME) + if (streq (Memc[extn], "pl")) + pm = immap (fname, mode, refim) + else { + call strcpy (fname, Memc[extn], SZ_FNAME) + call strcat (".pl", Memc[extn], SZ_FNAME) + pm = immap (Memc[extn], mode, refim) + } + + call sfree (sp) + return (pm) +end diff --git a/pkg/images/immatch/src/imcombine/src/icquad.gx b/pkg/images/immatch/src/imcombine/src/icquad.gx new file mode 100644 index 00000000..4ecf3aa0 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icquad.gx @@ -0,0 +1,133 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../icombine.h" +include "../icmask.h" + +$for (sird) +# IC_QUAD -- Compute the quadrature average (or summed) image line. +# Options include a weighted average/sum. + +procedure ic_quad$t (d, m, n, wts, nimages, npts, doblank, doaverage, + average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image ID pointers +int n[npts] # Number of points +real wts[nimages] # Weights +int nimages # Number of images +int npts # Number of output points per line +int doblank # Set blank values? +int doaverage # Do average? +$if (datatype == sil) +real average[npts] # Average (returned) +$else +PIXEL average[npts] # Average (returned) +$endif + +int i, j, k, n1 +real val, wt, sumwt +$if (datatype == sil) +real sum +$else +PIXEL sum +$endif + +include "../icombine.com" + +begin + # If no data has been excluded do the average/sum without checking + # the number of points and using the fact that the weights are + # normalized. If all the data has been excluded set the average/sum + # to the blank value if requested. + + if (dflag == D_ALL) { + if (dowts && doaverage == YES) { + do i = 1, npts { + k = i - 1 + val = Mem$t[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + do j = 2, n[i] { + val = Mem$t[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val * wt) ** 2 + } + average[i] = sqrt(sum) + } + } else { + do i = 1, npts { + k = i - 1 + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n[i] { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n[i] + else + average[i] = sqrt(sum) + } + } + } else if (dflag == D_NONE) { + if (doblank == YES) { + do i = 1, npts + average[i] = blank + } + } else { + if (dowts && doaverage == YES) { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mem$t[d[1]+k] + wt = wts[Memi[m[1]+k]] + sum = (val * wt) ** 2 + sumwt = wt + do j = 2, n1 { + val = Mem$t[d[j]+k] + wt = wts[Memi[m[j]+k]] + sum = sum + (val* wt) ** 2 + sumwt = sumwt + wt + } + if (doaverage == YES) { + if (sumwt > 0) + average[i] = sqrt(sum) / sumwt + else { + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + average[i] = sqrt(sum) / n1 + } + } else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } else { + do i = 1, npts { + n1 = abs(n[i]) + if (n1 > 0) { + k = i - 1 + val = Mem$t[d[1]+k] + sum = val**2 + do j = 2, n1 { + val = Mem$t[d[j]+k] + sum = sum + val**2 + } + if (doaverage == YES) + average[i] = sqrt(sum) / n1 + else + average[i] = sqrt(sum) + } else if (doblank == YES) + average[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icrmasks.x b/pkg/images/immatch/src/imcombine/src/icrmasks.x new file mode 100644 index 00000000..8b9a0c3d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icrmasks.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IC_RMASKS -- Set pixels for rejection mask. + +procedure ic_rmasks (pm, v, id, nimages, n, npts) + +pointer pm #I Pixel mask +long v[ARB] #I Output vector (input) +pointer id[nimages] #I Image id pointers +int nimages #I Number of images +int n[npts] #I Number of good pixels +int npts #I Number of output points per line + +int i, j, k, ndim, impnls() +long v1[IM_MAXDIM] +pointer buf + +begin + ndim = IM_NDIM(pm) + do k = 1, nimages { + call amovl (v, v1, ndim-1) + v1[ndim] = k + i = impnls (pm, buf, v1) + do j = 1, npts { + if (n[j] == nimages) + Mems[buf+j-1] = 0 + else { + Mems[buf+j-1] = 1 + do i = 1, n[j] { + if (Memi[id[i]+j-1] == k) { + Mems[buf+j-1] = 0 + break + } + } + } + } + } +end diff --git a/pkg/images/immatch/src/imcombine/src/icscale.x b/pkg/images/immatch/src/imcombine/src/icscale.x new file mode 100644 index 00000000..42d62f8d --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icscale.x @@ -0,0 +1,351 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "icombine.h" + + +# IC_SCALE -- Get and set the scaling factors. +# +# If the scaling parameters have been set earlier then this routine +# just normalizes the factors and writes the log output. +# When dealing with individual images using image statistics for scaling +# factors this routine determines the image statistics rather than being +# done earlier since the input images have all been mapped at this stage. + +procedure ic_scale (in, out, offsets, scales, zeros, wts, nimages) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Image offsets +real scales[nimages] # Scale factors +real zeros[nimages] # Zero or sky levels +real wts[nimages] # Weights +int nimages # Number of images + +int stype, ztype, wtype +int i, j, k, l, nout +real mode, median, mean, sumwts +pointer sp, ncombine, exptime, modes, medians, means +pointer section, str, sname, zname, wname, im, imref +bool domode, domedian, domean, dozero, dos, doz, dow, snorm, znorm, wflag + +int imgeti(), strdic(), ic_gscale() +real imgetr(), asumr(), asumi() +pointer xt_opix() +errchk ic_gscale, xt_opix, ic_statr + +include "icombine.com" + +begin + call smark (sp) + call salloc (ncombine, nimages, TY_INT) + call salloc (exptime, nimages, TY_REAL) + call salloc (modes, nimages, TY_REAL) + call salloc (medians, nimages, TY_REAL) + call salloc (means, nimages, TY_REAL) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (sname, SZ_FNAME, TY_CHAR) + call salloc (zname, SZ_FNAME, TY_CHAR) + call salloc (wname, SZ_FNAME, TY_CHAR) + + # Get the number of images previously combined and the exposure times. + # The default combine number is 1 and the default exposure is 0. + + do i = 1, nimages { + iferr (Memi[ncombine+i-1] = imgeti (in[i], "ncombine")) + Memi[ncombine+i-1] = 1 + if (Memc[expkeyword] != EOS) { + iferr (Memr[exptime+i-1] = imgetr (in[i], Memc[expkeyword])) + Memr[exptime+i-1] = 0. + } else + Memr[exptime+i-1] = 0. + if (project) { + call amovki (Memi[ncombine], Memi[ncombine], nimages) + call amovkr (Memr[exptime], Memr[exptime], nimages) + break + } + } + + # Set scaling type and factors. + stype = ic_gscale ("scale", Memc[sname], STYPES, in, Memr[exptime], + scales, nimages) + ztype = ic_gscale ("zero", Memc[zname], ZTYPES, in, Memr[exptime], + zeros, nimages) + wtype = ic_gscale ("weight", Memc[wname], WTYPES, in, Memr[exptime], + wts, nimages) + + # Get image statistics if needed. + dos = ((stype==S_MODE)||(stype==S_MEDIAN)||(stype==S_MEAN)) + doz = ((ztype==S_MODE)||(ztype==S_MEDIAN)||(ztype==S_MEAN)) + dow = ((wtype==S_MODE)||(wtype==S_MEDIAN)||(wtype==S_MEAN)) + if (dos) { + dos = false + do i = 1, nimages + if (IS_INDEFR(scales[i])) { + dos = true + break + } + } + if (doz) { + doz = false + do i = 1, nimages + if (IS_INDEFR(zeros[i])) { + doz = true + break + } + } + if (dow) { + dow = false + do i = 1, nimages + if (IS_INDEFR(wts[i])) { + dow = true + break + } + } + + if (dos || doz || dow) { + domode = ((stype==S_MODE)||(ztype==S_MODE)||(wtype==S_MODE)) + domedian = ((stype==S_MEDIAN)||(ztype==S_MEDIAN)||(wtype==S_MEDIAN)) + domean = ((stype==S_MEAN)||(ztype==S_MEAN)||(wtype==S_MEAN)) + + Memc[section] = EOS + Memc[str] = EOS + call sscan (Memc[statsec]) + call gargwrd (Memc[section], SZ_FNAME) + call gargwrd (Memc[str], SZ_LINE) + + i = strdic (Memc[section], Memc[section], SZ_FNAME, S_SECTION) + switch (i) { + case S_INPUT: + call strcpy (Memc[str], Memc[section], SZ_FNAME) + imref = NULL + case S_OUTPUT: + call strcpy (Memc[str], Memc[section], SZ_FNAME) + imref = out[1] + case S_OVERLAP: + call strcpy ("[", Memc[section], SZ_FNAME) + do i = 1, IM_NDIM(out[1]) { + k = offsets[1,i] + 1 + l = offsets[1,i] + IM_LEN(in[1],i) + do j = 2, nimages { + k = max (k, offsets[j,i]+1) + l = min (l, offsets[j,i]+IM_LEN(in[j],i)) + } + if (i < IM_NDIM(out[1])) + call sprintf (Memc[str], SZ_LINE, "%d:%d,") + else + call sprintf (Memc[str], SZ_LINE, "%d:%d]") + call pargi (k) + call pargi (l) + call strcat (Memc[str], Memc[section], SZ_FNAME) + } + imref = out[1] + default: + imref = NULL + } + + do i = 1, nimages { + im = xt_opix (in[i], i, 0) + if (imref != out[1]) + imref = im + if ((dos && IS_INDEFR(scales[i])) || + (doz && IS_INDEFR(zeros[i])) || + (dow && IS_INDEFR(wts[i]))) { + call ic_statr (im, imref, Memc[section], offsets, i, + nimages, domode, domedian, domean, mode, median, mean) + if (domode) { + if (stype == S_MODE && IS_INDEFR(scales[i])) + scales[i] = mode + if (ztype == S_MODE && IS_INDEFR(zeros[i])) + zeros[i] = mode + if (wtype == S_MODE && IS_INDEFR(wts[i])) + wts[i] = mode + } + if (domedian) { + if (stype == S_MEDIAN && IS_INDEFR(scales[i])) + scales[i] = median + if (ztype == S_MEDIAN && IS_INDEFR(zeros[i])) + zeros[i] = median + if (wtype == S_MEDIAN && IS_INDEFR(wts[i])) + wts[i] = median + } + if (domean) { + if (stype == S_MEAN && IS_INDEFR(scales[i])) + scales[i] = mean + if (ztype == S_MEAN && IS_INDEFR(zeros[i])) + zeros[i] = mean + if (wtype == S_MEAN && IS_INDEFR(wts[i])) + wts[i] = mean + } + } + } + } + + # Save the image statistics if computed. + call amovkr (INDEFR, Memr[modes], nimages) + call amovkr (INDEFR, Memr[medians], nimages) + call amovkr (INDEFR, Memr[means], nimages) + if (stype == S_MODE) + call amovr (scales, Memr[modes], nimages) + if (stype == S_MEDIAN) + call amovr (scales, Memr[medians], nimages) + if (stype == S_MEAN) + call amovr (scales, Memr[means], nimages) + if (ztype == S_MODE) + call amovr (zeros, Memr[modes], nimages) + if (ztype == S_MEDIAN) + call amovr (zeros, Memr[medians], nimages) + if (ztype == S_MEAN) + call amovr (zeros, Memr[means], nimages) + if (wtype == S_MODE) + call amovr (wts, Memr[modes], nimages) + if (wtype == S_MEDIAN) + call amovr (wts, Memr[medians], nimages) + if (wtype == S_MEAN) + call amovr (wts, Memr[means], nimages) + + # If nothing else has set the scaling factors set them to defaults. + do i = 1, nimages { + if (IS_INDEFR(scales[i])) + scales[i] = 1. + if (IS_INDEFR(zeros[i])) + zeros[i] = 0. + if (IS_INDEFR(wts[i])) + wts[i] = 1. + } + + do i = 1, nimages + if (scales[i] <= 0.) { + call eprintf ("WARNING: Negative scale factors") + call eprintf (" -- ignoring scaling\n") + call amovkr (1., scales, nimages) + break + } + + # Convert to factors relative to the first image. + snorm = (stype == S_FILE || stype == S_KEYWORD) + znorm = (ztype == S_FILE || ztype == S_KEYWORD) + wflag = (wtype == S_FILE || wtype == S_KEYWORD) + if (snorm) + call arcpr (1., scales, scales, nimages) + mean = scales[1] + call adivkr (scales, mean, scales, nimages) + call adivr (zeros, scales, zeros, nimages) + + if (wtype != S_NONE) { + do i = 1, nimages { + if (wts[i] < 0.) { + call eprintf ("WARNING: Negative weights") + call eprintf (" -- using only NCOMBINE weights\n") + do j = 1, nimages + wts[j] = Memi[ncombine+j-1] + break + } + if (ztype == S_NONE || znorm || wflag) + wts[i] = Memi[ncombine+i-1] * wts[i] + else { + if (zeros[i] <= 0.) { + call eprintf ("WARNING: Negative zero offsets") + call eprintf (" -- ignoring zero weight adjustments\n") + do j = 1, nimages + wts[j] = Memi[ncombine+j-1] * wts[j] + break + } + wts[i] = Memi[ncombine+i-1] * wts[i] * zeros[1] / zeros[i] + } + } + } + + if (znorm) + call anegr (zeros, zeros, nimages) + else { + # Because of finite arithmetic it is possible for the zero offsets + # to be nonzero even when they are all equal. Just for the sake of + # a nice log set the zero offsets in this case. + + mean = zeros[1] + call asubkr (zeros, mean, zeros, nimages) + for (i=2; (i<=nimages)&&(zeros[i]==zeros[1]); i=i+1) + ; + if (i > nimages) + call aclrr (zeros, nimages) + } + mean = asumr (wts, nimages) + if (mean > 0.) + call adivkr (wts, mean, wts, nimages) + else { + call eprintf ("WARNING: Mean weight is zero -- using no weights\n") + call amovkr (1., wts, nimages) + mean = 1. + } + + # Set flags for scaling, zero offsets, sigma scaling, weights. + # Sigma scaling may be suppressed if the scales or zeros are + # different by a specified tolerance. + + doscale = false + dozero = false + doscale1 = false + dowts = false + do i = 2, nimages { + if (snorm || scales[i] != scales[1]) + doscale = true + if (znorm || zeros[i] != zeros[1]) + dozero = true + if (wts[i] != wts[1]) + dowts = true + } + if (doscale && sigscale != 0.) { + do i = 1, nimages { + if (abs (scales[i] - 1) > sigscale) { + doscale1 = true + break + } + } + } + + # Set the output header parameters. + nout = asumi (Memi[ncombine], nimages) + call imaddi (out[1], "ncombine", nout) + mean = 0. + sumwts = 0. + do i = 1, nimages { + ifnoerr (mode = imgetr (in[i], "ccdmean")) { + mean = mean + wts[i] * mode / scales[i] + sumwts = sumwts + wts[i] + } + } + if (sumwts > 0.) { + mean = mean / sumwts + ifnoerr (mode = imgetr (out[1], "ccdmean")) { + call imaddr (out[1], "ccdmean", mean) + iferr (call imdelf (out[1], "ccdmeant")) + ; + } + } + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[str], SZ_FNAME) + call imastr (out[1], "BPM", Memc[str]) + } + + # Start the log here since much of the info is only available here. + if (verbose) { + i = logfd + logfd = STDOUT + call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], + Memc[zname], Memc[wname], Memr[modes], Memr[medians], + Memr[means], scales, zeros, wts, offsets, nimages, dozero, + nout) + + logfd = i + } + call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], + Memc[zname], Memc[wname], Memr[modes], Memr[medians], Memr[means], + scales, zeros, wts, offsets, nimages, dozero, nout) + + doscale = (doscale || dozero) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icsclip.gx b/pkg/images/immatch/src/imcombine/src/icsclip.gx new file mode 100644 index 00000000..e4d8f027 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsclip.gx @@ -0,0 +1,504 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +define MINCLIP 3 # Mininum number of images for algorithm + +$for (sird) +# IC_ASIGCLIP -- Reject pixels using sigma clipping about the average +# The initial average rejects the high and low pixels. A correction for +# different scalings of the images may be made. Weights are not used. + +procedure ic_asigclip$t (d, m, n, scales, zeros, nimages, npts, average) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +$else +PIXEL average[npts] # Average +$endif + +int i, j, k, l, jj, n1, n2, nin, nk, maxkeep +$if (datatype == sil) +real d1, low, high, sum, a, s, r, one +data one /1.0/ +$else +PIXEL d1, low, high, sum, a, s, r, one +data one /1$f/ +$endif +pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Flag whether returned average needs to be recomputed. + if (dowts || combine != AVERAGE) + docombine = true + else + docombine = false + + # Save the residuals and the sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Do sigma clipping. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + + # If there are not enough pixels simply compute the average. + if (n1 < max (3, maxkeep)) { + if (!docombine) { + if (n1 == 0) + average[i] = blank + else { + sum = Mem$t[d[1]+k] + do j = 2, n1 + sum = sum + Mem$t[d[j]+k] + average[i] = sum / n1 + } + } + next + } + + # Compute average with the high and low rejected. + low = Mem$t[d[1]+k] + high = Mem$t[d[2]+k] + if (low > high) { + d1 = low + low = high + high = d1 + } + sum = 0. + do j = 3, n1 { + d1 = Mem$t[d[j]+k] + if (d1 < low) { + sum = sum + low + low = d1 + } else if (d1 > high) { + sum = sum + high + high = d1 + } else + sum = sum + d1 + } + a = sum / (n1 - 2) + sum = sum + low + high + + # Iteratively reject pixels and compute the final average if needed. + # Compact the data and keep track of the image IDs if needed. + + repeat { + n2 = n1 + if (doscale1) { + # Compute sigma corrected for scaling. + s = 0. + wp = w - 1 + do j = 1, n1 { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mem$t[dp1] + l = Memi[mp1] + r = sqrt (max (one, (a + zeros[l]) / scales[l])) + s = s + ((d1 - a) / r) ** 2 + Memr[wp] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + wp = w - 1 + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + wp = wp + 1 + + d1 = Mem$t[dp1] + r = (d1 - a) / (s * Memr[wp]) + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + Memr[wp] = Memr[w+n1-1] + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } else { + # Compute the sigma without scale correction. + s = 0. + do j = 1, n1 + s = s + (Mem$t[d[j]+k] - a) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels. Save the residuals and data values. + if (s > 0.) { + for (j=1; j<=n1; j=j+1) { + dp1 = d[j] + k + d1 = Mem$t[dp1] + r = (d1 - a) / s + if (r < -lsigma || r > hsigma) { + Memr[resid+n1] = abs (r) + if (j < n1) { + dp2 = d[n1] + k + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[n1] + k + l = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = l + } + j = j - 1 + } + sum = sum - d1 + n1 = n1 - 1 + } + } + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } until (n1 == n2 || n1 <= max (2, maxkeep)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + if (n1 < maxkeep) { + nk = maxkeep + if (doscale1) { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + mp1 = m[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } else { + for (j=n1+1; j<=nk; j=j+1) { + dp1 = d[j] + k + r = Memr[resid+j] + jj = 0 + do l = j+1, n2 { + s = Memr[resid+l] + if (s < r + TOL) { + if (s > r - TOL) + jj = jj + 1 + else { + jj = 0 + Memr[resid+l] = r + r = s + dp2 = d[l] + k + d1 = Mem$t[dp1] + Mem$t[dp1] = Mem$t[dp2] + Mem$t[dp2] = d1 + if (keepids) { + mp1 = m[j] + k + mp2 = m[l] + k + s = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = s + } + } + } + } + sum = sum + Mem$t[dp1] + n1 = n1 + 1 + nk = max (nk, j+jj) + } + } + + # Recompute the average. + if (n1 > 1) + a = sum / n1 + } + + # Save the average if needed. + n[i] = n1 + if (!docombine) { + if (n1 > 0) + average[i] = a + else + average[i] = blank + } + } + + # Check if the data flag has to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + call sfree (sp) +end + + +# IC_MSIGCLIP -- Reject pixels using sigma clipping about the median + +procedure ic_msigclip$t (d, m, n, scales, zeros, nimages, npts, median) + +pointer d[nimages] # Data pointers +pointer m[nimages] # Image id pointers +int n[npts] # Number of good pixels +real scales[nimages] # Scales +real zeros[nimages] # Zeros +int nimages # Number of images +int npts # Number of output points per line +$if (datatype == sil) +real median[npts] # Median +$else +PIXEL median[npts] # Median +$endif + +int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep +real r, s +pointer sp, resid, w, mp1, mp2 +$if (datatype == sil) +real med, one +data one /1.0/ +$else +PIXEL med, one +data one /1$f/ +$endif + +include "../icombine.com" + +begin + # If there are insufficient pixels go on to the combining + if (nkeep < 0) + maxkeep = max (0, nimages + nkeep) + else + maxkeep = min (nimages, nkeep) + if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { + docombine = true + return + } + + # Save the residuals and sigma scaling corrections if needed. + call smark (sp) + call salloc (resid, nimages+1, TY_REAL) + if (doscale1) + call salloc (w, nimages, TY_REAL) + + # Compute median and sigma and iteratively clip. + nin = max (0, n[1]) + do i = 1, npts { + k = i - 1 + n1 = max (0, n[i]) + if (nkeep < 0) + maxkeep = max (0, n1 + nkeep) + else + maxkeep = min (n1, nkeep) + nl = 1 + nh = n1 + + repeat { + n2 = n1 + n3 = nl + n1 / 2 + + if (n1 == 0) + med = blank + else if (mod (n1, 2) == 0) + med = (Mem$t[d[n3-1]+k] + Mem$t[d[n3]+k]) / 2. + else + med = Mem$t[d[n3]+k] + + if (n1 >= max (MINCLIP, maxkeep+1)) { + if (doscale1) { + # Compute the sigma with scaling correction. + s = 0. + do j = nl, nh { + l = Memi[m[j]+k] + r = sqrt (max (one, (med + zeros[l]) / scales[l])) + s = s + ((Mem$t[d[j]+k] - med) / r) ** 2 + Memr[w+j-1] = r + } + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / (s * Memr[w+nl-1]) + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / (s * Memr[w+nh-1]) + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } else { + # Compute the sigma without scaling correction. + s = 0. + do j = nl, nh + s = s + (Mem$t[d[j]+k] - med) ** 2 + s = sqrt (s / (n1 - 1)) + + # Reject pixels and save the residuals. + if (s > 0.) { + for (; nl <= nh; nl = nl + 1) { + r = (med - Mem$t[d[nl]+k]) / s + if (r <= lsigma) + break + Memr[resid+nl] = r + n1 = n1 - 1 + } + for (; nh >= nl; nh = nh - 1) { + r = (Mem$t[d[nh]+k] - med) / s + if (r <= hsigma) + break + Memr[resid+nh] = r + n1 = n1 - 1 + } + } + } + } + } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) + + # If too many pixels are rejected add some back. + # All pixels with equal residuals are added back. + while (n1 < maxkeep) { + if (nl == 1) + nh = nh + 1 + else if (nh == max (0, n[i])) + nl = nl - 1 + else { + r = Memr[resid+nl-1] + s = Memr[resid+nh+1] + if (r < s) { + nl = nl - 1 + r = r + TOL + if (s <= r) + nh = nh + 1 + if (nl > 1) { + if (Memr[resid+nl-1] <= r) + nl = nl - 1 + } + } else { + nh = nh + 1 + s = s + TOL + if (r <= s) + nl = nl - 1 + if (nh < n2) { + if (Memr[resid+nh+1] <= s) + nh = nh + 1 + } + } + } + n1 = nh - nl + 1 + } + + # Only set median and reorder if needed + n[i] = n1 + if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + if (grow >= 1.) { + mp1 = m[l] + k + mp2 = m[j] + k + id = Memi[mp1] + Memi[mp1] = Memi[mp2] + Memi[mp2] = id + } else + Memi[m[l]+k] = Memi[m[j]+k] + j = j + 1 + } + } else { + do l = 1, min (n1, nl - 1) { + Mem$t[d[l]+k] = Mem$t[d[j]+k] + j = j + 1 + } + } + } + + if (combine == MEDIAN) + median[i] = med + } + + # Check if data flag needs to be reset for rejected pixels + if (dflag == D_ALL) { + do i = 1, npts { + if (max (0, n[i]) != nin) { + dflag = D_MIX + break + } + } + } + + # Flag that the median has been computed. + if (combine == MEDIAN) + docombine = false + else + docombine = true + + call sfree (sp) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icsection.x b/pkg/images/immatch/src/imcombine/src/icsection.x new file mode 100644 index 00000000..746c1f51 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsection.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IC_SECTION -- Parse an image section into its elements. +# 1. The default values must be set by the caller. +# 2. A null image section is OK. +# 3. The first nonwhitespace character must be '['. +# 4. The last interpreted character must be ']'. +# +# This procedure should be replaced with an IMIO procedure at some +# point. + +procedure ic_section (section, x1, x2, xs, ndim) + +char section[ARB] # Image section +int x1[ndim] # Starting pixel +int x2[ndim] # Ending pixel +int xs[ndim] # Step +int ndim # Number of dimensions + +int i, ip, a, b, c, temp, ctoi() +define error_ 99 + +begin + # Decode the section string. + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') + ip = ip + 1 + else if (section[ip] == EOS) + return + else + goto error_ + + do i = 1, ndim { + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ']') + break + + # Default values + a = x1[i] + b = x2[i] + c = xs[i] + + # Get a:b:c. Allow notation such as "-*:c" + # (or even "-:c") where the step is obviously negative. + + if (ctoi (section, ip, temp) > 0) { # a + a = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b) == 0) # a:b + goto error_ + } else + b = a + } else if (section[ip] == '-') { # -* + temp = a + a = b + b = temp + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + } else if (section[ip] == '*') # * + ip = ip + 1 + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, c) == 0) + goto error_ + else if (c == 0) + goto error_ + } + if (a > b && c > 0) + c = -c + + x1[i] = a + x2[i] = b + xs[i] = c + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ',') + ip = ip + 1 + } + + if (section[ip] != ']') + goto error_ + + return +error_ + call error (0, "Error in image section specification") +end diff --git a/pkg/images/immatch/src/imcombine/src/icsetout.x b/pkg/images/immatch/src/imcombine/src/icsetout.x new file mode 100644 index 00000000..efe55681 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsetout.x @@ -0,0 +1,332 @@ +include +include +include + +define OFFTYPES "|none|wcs|world|physical|grid|" +define FILE 0 +define NONE 1 +define WCS 2 +define WORLD 3 +define PHYSICAL 4 +define GRID 5 + +# IC_SETOUT -- Set output image size and offsets of input images. + +procedure ic_setout (in, out, offsets, nimages) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Offsets +int nimages # Number of images + +int i, j, indim, outdim, mwdim, a, b, amin, bmax, fd, offtype, npix +real val +bool proj, reloff, flip, streq(), fp_equald() +pointer sp, str, fname +pointer ltv, lref, wref, cd, ltm, coord, shift, axno, axval, section +pointer mw, ct, mw_openim(), mw_sctran(), xt_immap() +int open(), fscan(), nscan(), mw_stati(), strlen(), strdic() +errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap +errchk mw_sctran, mw_ctrand, open, xt_immap + +include "icombine.com" +define newscan_ 10 + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (ltv, IM_MAXDIM, TY_DOUBLE) + call salloc (ltm, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) + call salloc (lref, IM_MAXDIM, TY_DOUBLE) + call salloc (wref, IM_MAXDIM, TY_DOUBLE) + call salloc (cd, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) + call salloc (coord, IM_MAXDIM, TY_DOUBLE) + call salloc (shift, IM_MAXDIM, TY_REAL) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + + # Check and set the image dimensionality. + indim = IM_NDIM(in[1]) + outdim = IM_NDIM(out[1]) + proj = (indim != outdim) + if (!proj) { + do i = 1, nimages + if (IM_NDIM(in[i]) != outdim) { + call sfree (sp) + call error (1, "Image dimensions are not the same") + } + } + + # Set the reference point to that of the first image. + mw = mw_openim (in[1]) + call mw_seti (mw, MW_USEAXMAP, NO) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], mwdim) + call mw_ctfree (ct) + if (proj) + Memd[lref+outdim] = 1 + + # Parse the user offset string. If "none" then there are no offsets. + # If "world" or "wcs" then set the offsets based on the world WCS. + # If "physical" then set the offsets based on the physical WCS. + # If "grid" then set the offsets based on the input grid parameters. + # If a file scan it. + + call clgstr ("offsets", Memc[fname], SZ_FNAME) + call sscan (Memc[fname]) + call gargwrd (Memc[fname], SZ_FNAME) + if (nscan() == 0) + offtype = NONE + else { + offtype = strdic (Memc[fname], Memc[str], SZ_FNAME, OFFTYPES) + if (offtype > 0 && !streq (Memc[fname], Memc[str])) + offtype = 0 + } + if (offtype == 0) + offtype = FILE + + switch (offtype) { + case NONE: + call aclri (offsets, outdim*nimages) + reloff = true + case WORLD, WCS: + do j = 1, outdim + offsets[1,j] = 0 + if (proj) { + ct = mw_sctran (mw, "world", "logical", 0) + do i = 2, nimages { + Memd[wref+outdim] = i + call mw_ctrand (ct, Memd[wref], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + } + call mw_ctfree (ct) + call mw_close (mw) + } else { + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[lref], indim) + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + ct = mw_sctran (mw, "world", "logical", 0) + call mw_ctrand (ct, Memd[wref], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + call mw_ctfree (ct) + } + } + reloff = true + case PHYSICAL: + call salloc (section, SZ_FNAME, TY_CHAR) + + call mw_gltermd (mw, Memd[ltm], Memd[coord], indim) + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + call mw_gltermd (mw, Memd[cd], Memd[coord], indim) + call strcpy ("[", Memc[section], SZ_FNAME) + flip = false + do j = 0, indim*indim-1, indim+1 { + if (Memd[ltm+j] * Memd[cd+j] >= 0.) + call strcat ("*,", Memc[section], SZ_FNAME) + else { + call strcat ("-*,", Memc[section], SZ_FNAME) + flip = true + } + } + Memc[section+strlen(Memc[section])-1] = ']' + if (flip) { + call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_FNAME) + call strcat (Memc[section], Memc[fname], SZ_FNAME) + call xt_imunmap (in[i], i) + in[i] = xt_immap (Memc[fname], READ_ONLY, TY_CHAR, i, 0) + call mw_close (mw) + mw = mw_openim (in[i]) + call mw_gltermd (mw, Memd[cd], Memd[coord], indim) + do j = 0, indim*indim-1 + if (!fp_equald (Memd[ltm+j], Memd[cd+j])) + call error (1, + "Cannot match physical coordinates") + } + } + + call mw_close (mw) + mw = mw_openim (in[1]) + ct = mw_sctran (mw, "logical", "physical", 0) + call mw_ctrand (ct, Memd[lref], Memd[ltv], indim) + call mw_ctfree (ct) + do j = 1, outdim + offsets[1,j] = 0 + if (proj) { + ct = mw_sctran (mw, "physical", "logical", 0) + do i = 2, nimages { + Memd[ltv+outdim] = i + call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + } + call mw_ctfree (ct) + call mw_close (mw) + } else { + do i = 2, nimages { + call mw_close (mw) + mw = mw_openim (in[i]) + ct = mw_sctran (mw, "physical", "logical", 0) + call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) + do j = 1, outdim + offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) + call mw_ctfree (ct) + } + } + reloff = true + case GRID: + amin = 1 + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 1+2*j) { + a = 1 + b = 0 + } + do i = 1, nimages + offsets[i,j] = mod ((i-1)/amin, a) * b + amin = amin * a + } + reloff = true + case FILE: + reloff = true + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + do i = 1, nimages { +newscan_ if (fscan (fd) == EOF) + call error (1, "IMCOMBINE: Offset list too short") + call gargwrd (Memc[fname], SZ_FNAME) + if (Memc[fname] == '#') { + call gargwrd (Memc[fname], SZ_FNAME) + call strlwr (Memc[fname]) + if (streq (Memc[fname], "absolute")) + reloff = false + else if (streq (Memc[fname], "relative")) + reloff = true + goto newscan_ + } + call reset_scan () + do j = 1, outdim { + call gargr (val) + offsets[i,j] = nint (val) + } + if (nscan() < outdim) + call error (1, "IMCOMBINE: Error in offset list") + } + call close (fd) + } + + # Set the output image size and the aligned flag + aligned = true + do j = 1, outdim { + a = offsets[1,j] + b = IM_LEN(in[1],j) + a + amin = a + bmax = b + do i = 2, nimages { + a = offsets[i,j] + b = IM_LEN(in[i],j) + a + if (a != amin || b != bmax || !reloff) + aligned = false + amin = min (a, amin) + bmax = max (b, bmax) + } + IM_LEN(out[1],j) = bmax + if (reloff || amin < 0) { + do i = 1, nimages + offsets[i,j] = offsets[i,j] - amin + IM_LEN(out[1],j) = IM_LEN(out[1],j) - amin + } + } + + # Get the output limits. + call clgstr ("outlimits", Memc[fname], SZ_FNAME) + call sscan (Memc[fname]) + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 2*j) + break + if (!IS_INDEFI(a)) { + do i = 1, nimages { + offsets[i,j] = offsets[i,j] - a + 1 + if (offsets[i,j] != 0) + aligned = false + } + IM_LEN(out[1],j) = IM_LEN(out[1],j) - a + 1 + } + if (!IS_INDEFI(a) && !IS_INDEFI(b)) + IM_LEN(out[1],j) = min (IM_LEN(out[1],j), b - a + 1) + } + + # Update the WCS. + if (proj || !aligned || !reloff) { + call mw_close (mw) + mw = mw_openim (out[1]) + mwdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gaxmap (mw, Memi[axno], Memi[axval], mwdim) + if (!aligned || !reloff) { + call mw_gltermd (mw, Memd[cd], Memd[lref], mwdim) + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j > 0 && j <= indim) + Memd[lref+i-1] = Memd[lref+i-1] + offsets[1,j] + } + if (proj) + Memd[lref+mwdim-1] = 0. + call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) + } + if (proj) { + # Apply dimensional reduction. + do i = 1, mwdim { + j = Memi[axno+i-1] + if (j <= outdim) + next + else if (j > outdim+1) + Memi[axno+i-1] = j - 1 + else { + Memi[axno+i-1] = 0 + Memi[axval+i-1] = 0 + } + } + call mw_saxmap (mw, Memi[axno], Memi[axval], mwdim) + } + + # Reset physical coordinates. + if (offtype == WCS || offtype == WORLD) { + call mw_gltermd (mw, Memd[ltm], Memd[ltv], mwdim) + call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call mwvmuld (Memd[ltm], Memd[lref], Memd[lref], mwdim) + call aaddd (Memd[lref], Memd[ltv], Memd[lref], mwdim) + call mwinvertd (Memd[ltm], Memd[ltm], mwdim) + call mwmmuld (Memd[cd], Memd[ltm], Memd[cd], mwdim) + call mw_swtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) + call aclrd (Memd[ltv], mwdim) + call aclrd (Memd[ltm], mwdim*mwdim) + do i = 1, mwdim + Memd[ltm+(i-1)*(mwdim+1)] = 1. + call mw_sltermd (mw, Memd[ltm], Memd[ltv], mwdim) + } + call mw_saveim (mw, out) + } + call mw_close (mw) + + # Throw an error if the output size is too large. + if (offtype != NONE) { + npix = IM_LEN(out[1],1) + do i = 2, outdim + npix = npix * IM_LEN(out[1],i) + npix = npix / 1000000000 + if (npix > 100) + call error (1, "Output has more than 100 Gpixels (check offsets)") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/src/icsigma.gx b/pkg/images/immatch/src/imcombine/src/icsigma.gx new file mode 100644 index 00000000..1304d940 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsigma.gx @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../icombine.h" + +$for (sird) +# IC_SIGMA -- Compute the sigma image line. +# The estimated sigma includes a correction for the finite population. +# Weights are used if desired. + +procedure ic_sigma$t (d, m, n, wts, npts, average, sigma) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image ID pointers +int n[npts] # Number of points +real wts[ARB] # Weights +int npts # Number of output points per line +$if (datatype == sil) +real average[npts] # Average +real sigma[npts] # Sigma line (returned) +$else +PIXEL average[npts] # Average +PIXEL sigma[npts] # Sigma line (returned) +$endif + +int i, j, k, n1 +real wt, sigcor, sumwt +$if (datatype == sil) +real a, sum +$else +PIXEL a, sum +$endif + +include "../icombine.com" + +begin + if (dflag == D_ALL) { + n1 = n[1] + if (dowts) { + if (n1 > 1) + sigcor = real (n1) / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mem$t[d[1]+k] - a) ** 2 * wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt + } + sigma[i] = sqrt (sum * sigcor) + } + } else { + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + do i = 1, npts { + k = i - 1 + a = average[i] + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } + } + } else if (dflag == D_NONE) { + do i = 1, npts + sigma[i] = blank + } else { + if (dowts) { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = real (n1) / real (n1 -1) + else + sigcor = 1 + a = average[i] + wt = wts[Memi[m[1]+k]] + sum = (Mem$t[d[1]+k] - a) ** 2 * wt + sumwt = wt + do j = 2, n1 { + wt = wts[Memi[m[j]+k]] + sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt + sumwt = sumwt + wt + } + if (sumwt > 0) + sigma[i] = sqrt (sum / sumwt * sigcor) + else { + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum / n1 * sigcor) + } + } else + sigma[i] = blank + } + } else { + do i = 1, npts { + n1 = n[i] + if (n1 > 0) { + k = i - 1 + if (n1 > 1) + sigcor = 1. / real (n1 - 1) + else + sigcor = 1. + a = average[i] + sum = (Mem$t[d[1]+k] - a) ** 2 + do j = 2, n1 + sum = sum + (Mem$t[d[j]+k] - a) ** 2 + sigma[i] = sqrt (sum * sigcor) + } else + sigma[i] = blank + } + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icsort.gx b/pkg/images/immatch/src/imcombine/src/icsort.gx new file mode 100644 index 00000000..e124da15 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icsort.gx @@ -0,0 +1,386 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +$for (sird) +# IC_SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. + +procedure ic_sort$t (a, b, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +PIXEL b[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +PIXEL pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] +define swap {temp=$1;$1=$2;$2=temp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix + b[i] = Mem$t[a[i]+l] + + # Special cases + $if (datatype == x) + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (abs (temp) < abs (pivot)) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (abs (temp) < abs (pivot)) { # bac|bca|cba + if (abs (temp) < abs (temp3)) { # bac|bca + b[1] = temp + if (abs (pivot) < abs (temp3)) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (abs (temp3) < abs (temp)) { # acb|cab + b[3] = temp + if (abs (pivot) < abs (temp3)) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + $else + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) # bac + b[2] = pivot + else { # bca + b[2] = temp3 + b[3] = pivot + } + } else { # cba + b[1] = temp3 + b[3] = pivot + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) # acb + b[2] = temp3 + else { # cab + b[1] = temp3 + b[2] = pivot + } + } else + next + } + goto copy_ + } + $endif + + # General case + do i = 1, npix + b[i] = Mem$t[a[i]+l] + + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) # out of order pair + swap (b[i], b[j]) # interchange elements + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix + Mem$t[a[i]+l] = b[i] + } +end + + +# IC_2SORT -- Quicksort. This is based on the VOPS asrt except that +# the input is an array of pointers to image lines and the sort is done +# across the image lines at each point along the lines. The number of +# valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 +# pixels per point are treated specially. A second integer set of +# vectors is sorted. + +procedure ic_2sort$t (a, b, c, d, nvecs, npts) + +pointer a[ARB] # pointer to input vectors +PIXEL b[ARB] # work array +pointer c[ARB] # pointer to associated integer vectors +int d[ARB] # work array +int nvecs[npts] # number of vectors +int npts # number of points in vectors + +PIXEL pivot, temp, temp3 +int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp +define swap {temp=$1;$1=$2;$2=temp} +define iswap {itemp=$1;$1=$2;$2=itemp} +define copy_ 10 + +begin + do l = 0, npts-1 { + npix = nvecs[l+1] + if (npix <= 1) + next + + do i = 1, npix { + b[i] = Mem$t[a[i]+l] + d[i] = Memi[c[i]+l] + } + + # Special cases + $if (datatype == x) + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (abs (temp) < abs (pivot)) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (abs (temp) < abs (pivot)) { # bac|bca|cba + if (abs (temp) < abs (temp3)) { # bac|bca + b[1] = temp + if (abs (pivot) < abs (temp3)) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (abs (temp3) < abs (temp)) { # acb|cab + b[3] = temp + if (abs (pivot) < abs (temp3)) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + $else + if (npix <= 3) { + pivot = b[1] + temp = b[2] + if (npix == 2) { + if (temp < pivot) { + b[1] = temp + b[2] = pivot + iswap (d[1], d[2]) + } else + next + } else { + temp3 = b[3] + if (temp < pivot) { # bac|bca|cba + if (temp < temp3) { # bac|bca + b[1] = temp + if (pivot < temp3) { # bac + b[2] = pivot + iswap (d[1], d[2]) + } else { # bca + b[2] = temp3 + b[3] = pivot + itemp = d[2] + d[2] = d[3] + d[3] = d[1] + d[1] = itemp + } + } else { # cba + b[1] = temp3 + b[3] = pivot + iswap (d[1], d[3]) + } + } else if (temp3 < temp) { # acb|cab + b[3] = temp + if (pivot < temp3) { # acb + b[2] = temp3 + iswap (d[2], d[3]) + } else { # cab + b[1] = temp3 + b[2] = pivot + itemp = d[2] + d[2] = d[1] + d[1] = d[3] + d[3] = itemp + } + } else + next + } + goto copy_ + } + $endif + + # General case + lv[1] = 1 + uv[1] = npix + p = 1 + + while (p > 0) { + if (lv[p] >= uv[p]) # only one elem in this subset + p = p - 1 # pop stack + else { + # Dummy do loop to trigger the Fortran optimizer. + do p = p, ARB { + i = lv[p] - 1 + j = uv[p] + + # Select as the pivot the element at the center of the + # array, to avoid quadratic behavior on an already + # sorted array. + + k = (lv[p] + uv[p]) / 2 + swap (b[j], b[k]); swap (d[j], d[k]) + pivot = b[j] # pivot line + + while (i < j) { + $if (datatype == x) + for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) + $else + for (i=i+1; b[i] < pivot; i=i+1) + $endif + ; + for (j=j-1; j > i; j=j-1) + $if (datatype == x) + if (abs(b[j]) <= abs(pivot)) + $else + if (b[j] <= pivot) + $endif + break + if (i < j) { # out of order pair + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + } + } + + j = uv[p] # move pivot to position i + swap (b[i], b[j]) # interchange elements + swap (d[i], d[j]) + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + break + } + p = p + 1 # push onto stack + } + } + +copy_ + do i = 1, npix { + Mem$t[a[i]+l] = b[i] + Memi[c[i]+l] = d[i] + } + } +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/icstat.gx b/pkg/images/immatch/src/imcombine/src/icstat.gx new file mode 100644 index 00000000..c594182b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/icstat.gx @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../icombine.h" + +define NMAX 100000 # Maximum number of pixels to sample + +$for (sird) +# IC_STAT -- Compute image statistics within specified section. +# The image section is relative to a reference image which may be +# different than the input image and may have an offset. Only a +# subsample of pixels is used. Masked and thresholded pixels are +# ignored. Only the desired statistics are computed to increase +# efficiency. + +procedure ic_stat$t (im, imref, section, offsets, image, nimages, + domode, domedian, domean, mode, median, mean) + +pointer im # Data image +pointer imref # Reference image for image section +char section[ARB] # Image section +int offsets[nimages,ARB] # Image section offset from data to reference +int image # Image index (for mask I/O) +int nimages # Number of images in offsets. +bool domode, domedian, domean # Statistics to compute +real mode, median, mean # Statistics + +int i, j, ndim, n, nv +real a +pointer sp, v1, v2, dv, va, vb +pointer data, mask, dp, lp, mp, imgnl$t() + +$if (datatype == csir) +real asum$t() +$else $if (datatype == ld) +double asum$t() +$else +PIXEL asum$t() +$endif $endif +PIXEL ic_mode$t() + +include "../icombine.com" + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (dv, IM_MAXDIM, TY_LONG) + call salloc (va, IM_MAXDIM, TY_LONG) + call salloc (vb, IM_MAXDIM, TY_LONG) + + # Determine the image section parameters. This must be in terms of + # the data image pixel coordinates though the section may be specified + # in terms of the reference image coordinates. Limit the number of + # pixels in each dimension to a maximum. + + ndim = IM_NDIM(im) + if (project) + ndim = ndim - 1 + call amovki (1, Memi[v1], IM_MAXDIM) + call amovki (1, Memi[va], IM_MAXDIM) + call amovki (1, Memi[dv], IM_MAXDIM) + call amovi (IM_LEN(imref,1), Memi[vb], ndim) + call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) + if (im != imref) + do i = 1, ndim { + Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] + Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] + } + + do j = 1, 10 { + n = 1 + do i = 0, ndim-1 { + Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) + Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) + Memi[dv+i] = j + nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] + n = n * nv + } + if (n < NMAX) + break + } + + call amovl (Memi[v1], Memi[va], IM_MAXDIM) + Memi[va] = 1 + if (project) + Memi[va+ndim] = image + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + + # Accumulate the pixel values within the section. Masked pixels and + # thresholded pixels are ignored. + + call salloc (data, n, TY_PIXEL) + dp = data + while (imgnl$t (im, lp, Memi[vb]) != EOF) { + call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) + lp = lp + Memi[v1] - 1 + if (dflag == D_ALL) { + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + a = Mem$t[lp] + if (a >= lthresh && a <= hthresh) { + Mem$t[dp] = a + dp = dp + 1 + } + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + Mem$t[dp] = Mem$t[lp] + dp = dp + 1 + lp = lp + Memi[dv] + } + } + } else if (dflag == D_MIX) { + mp = mask + Memi[v1] - 1 + if (dothresh) { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + a = Mem$t[lp] + if (a >= lthresh && a <= hthresh) { + Mem$t[dp] = a + dp = dp + 1 + } + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } else { + do i = Memi[v1], Memi[v2], Memi[dv] { + if (Memi[mp] == 0) { + Mem$t[dp] = Mem$t[lp] + dp = dp + 1 + } + mp = mp + Memi[dv] + lp = lp + Memi[dv] + } + } + } + for (i=2; i<=ndim; i=i+1) { + Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] + if (Memi[va+i-1] <= Memi[v2+i-1]) + break + Memi[va+i-1] = Memi[v1+i-1] + } + if (i > ndim) + break + call amovl (Memi[va], Memi[vb], IM_MAXDIM) + } + + # Close mask until it is needed again. + call ic_mclose1 (image, nimages) + + n = dp - data + if (n < 1) { + call sfree (sp) + call error (1, "Image section contains no pixels") + } + + # Compute only statistics needed. + if (domode || domedian) { + call asrt$t (Mem$t[data], Mem$t[data], n) + mode = ic_mode$t (Mem$t[data], n) + median = Mem$t[data+n/2-1] + } + if (domean) + mean = asum$t (Mem$t[data], n) / n + + call sfree (sp) +end + + +define NMIN 10 # Minimum number of pixels for mode calculation +define ZRANGE 0.7 # Fraction of pixels about median to use +define ZSTEP 0.01 # Step size for search for mode +define ZBIN 0.1 # Bin size for mode. + +# IC_MODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +PIXEL procedure ic_mode$t (a, n) + +PIXEL a[n] # Data array +int n # Number of points + +int i, j, k, nmax +real z1, z2, zstep, zbin +PIXEL mode +bool fp_equalr() + +begin + if (n < NMIN) + return (a[n/2]) + + # Compute the mode. The array must be sorted. Consider a + # range of values about the median point. Use a bin size which + # is ZBIN of the range. Step the bin limits in ZSTEP fraction of + # the bin size. + + i = 1 + n * (1. - ZRANGE) / 2. + j = 1 + n * (1. + ZRANGE) / 2. + z1 = a[i] + z2 = a[j] + if (fp_equalr (z1, z2)) { + mode = z1 + return (mode) + } + + zstep = ZSTEP * (z2 - z1) + zbin = ZBIN * (z2 - z1) + $if (datatype == sil) + zstep = max (1., zstep) + zbin = max (1., zbin) + $endif + + z1 = z1 - zstep + k = i + nmax = 0 + repeat { + z1 = z1 + zstep + z2 = z1 + zbin + for (; i < j && a[i] < z1; i=i+1) + ; + for (; k < j && a[k] < z2; k=k+1) + ; + if (k - i > nmax) { + nmax = k - i + mode = a[(i+k)/2] + } + } until (k >= j) + + return (mode) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/mkpkg b/pkg/images/immatch/src/imcombine/src/mkpkg new file mode 100644 index 00000000..5f53d4b8 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/mkpkg @@ -0,0 +1,67 @@ +# Make the IMCOMBINE library. + +update: + $checkout libimc.a lib$ + $update libimc.a + $checkin libimc.a lib$ + ; + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/icaclip.x, icaclip.gx) + $(GEN) icaclip.gx -o generic/icaclip.x $endif + $ifolder (generic/icaverage.x, icaverage.gx) + $(GEN) icaverage.gx -o generic/icaverage.x $endif + $ifolder (generic/icquad.x, icquad.gx) + $(GEN) icquad.gx -o generic/icquad.x $endif + $ifolder (generic/icnmodel.x, icnmodel.gx) + $(GEN) icnmodel.gx -o generic/icnmodel.x $endif + $ifolder (generic/iccclip.x, iccclip.gx) + $(GEN) iccclip.gx -o generic/iccclip.x $endif + $ifolder (generic/icgdata.x, icgdata.gx) + $(GEN) icgdata.gx -o generic/icgdata.x $endif + $ifolder (generic/icgrow.x, icgrow.gx) + $(GEN) icgrow.gx -o generic/icgrow.x $endif + $ifolder (generic/icmedian.x, icmedian.gx) + $(GEN) icmedian.gx -o generic/icmedian.x $endif + $ifolder (generic/icmm.x, icmm.gx) + $(GEN) icmm.gx -o generic/icmm.x $endif + $ifolder (generic/icomb.x, icomb.gx) + $(GEN) icomb.gx -o generic/icomb.x $endif + $ifolder (generic/icpclip.x, icpclip.gx) + $(GEN) icpclip.gx -o generic/icpclip.x $endif + $ifolder (generic/icsclip.x, icsclip.gx) + $(GEN) icsclip.gx -o generic/icsclip.x $endif + $ifolder (generic/icsigma.x, icsigma.gx) + $(GEN) icsigma.gx -o generic/icsigma.x $endif + $ifolder (generic/icsort.x, icsort.gx) + $(GEN) icsort.gx -o generic/icsort.x $endif + $ifolder (generic/icstat.x, icstat.gx) + $(GEN) icstat.gx -o generic/icstat.x $endif + + $ifolder (generic/xtimmap.x, xtimmap.gx) + $(GEN) xtimmap.gx -o generic/xtimmap.x $endif + ; + +libimc.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + icemask.x + icgscale.x icombine.com icombine.h + ichdr.x + icimstack.x + iclog.x icmask.h icombine.com icombine.h \ + + icmask.x icmask.h icombine.com icombine.h + icombine.x icombine.com icombine.h + icpmmap.x + icrmasks.x + icscale.x icombine.com icombine.h + icsection.x + icsetout.x icombine.com + tymax.x + xtprocid.x + ; diff --git a/pkg/images/immatch/src/imcombine/src/tymax.x b/pkg/images/immatch/src/imcombine/src/tymax.x new file mode 100644 index 00000000..a7f4f469 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/tymax.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# TY_MAX -- Return the datatype of highest precedence. + +int procedure ty_max (type1, type2) + +int type1, type2 # Datatypes + +int i, j, type, order[8] +data order/TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE,TY_COMPLEX,TY_REAL/ + +begin + for (i=1; (i<=7) && (type1!=order[i]); i=i+1) + ; + for (j=1; (j<=7) && (type2!=order[j]); j=j+1) + ; + type = order[max(i,j)] + + # Special case of mixing short and unsigned short. + if (type == TY_USHORT && type1 != type2) + type = TY_INT + + return (type) +end diff --git a/pkg/images/immatch/src/imcombine/src/xtimmap.gx b/pkg/images/immatch/src/imcombine/src/xtimmap.gx new file mode 100644 index 00000000..2e6cfb1e --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/xtimmap.gx @@ -0,0 +1,634 @@ +include +include +include +include +include + +# The following is for compiling under V2.11. +define IM_BUFFRAC IM_BUFSIZE +include + +define VERBOSE false + +# These routines maintain an arbitrary number of indexed "open" images which +# must be READ_ONLY. The calling program may use the returned pointer for +# header accesses but must call xt_opix before I/O. Subsequent calls to +# xt_opix may invalidate the pointer. The xt_imunmap call will free memory. + +define MAX_OPENIM (LAST_FD-16) # Maximum images kept open +define MAX_OPENPIX 45 # Maximum pixel files kept open + +define XT_SZIMNAME 299 # Size of IMNAME string +define XT_LEN 179 # Structure length +define XT_IMNAME Memc[P2C($1)] # Image name +define XT_ARG Memi[$1+150] # IMMAP header argument +define XT_IM Memi[$1+151] # IMIO pointer +define XT_HDR Memi[$1+152] # Copy of IMIO pointer +define XT_CLOSEFD Memi[$1+153] # Close FD? +define XT_FLAG Memi[$1+154] # Flag +define XT_BUFSIZE Memi[$1+155] # Buffer size +define XT_BUF Memi[$1+156] # Data buffer +define XT_BTYPE Memi[$1+157] # Data buffer type +define XT_VS Memi[$1+157+$2] # Start vector (10) +define XT_VE Memi[$1+167+$2] # End vector (10) + +# Options +define XT_MAPUNMAP 1 # Map and unmap images. + +# XT_IMMAP -- Map an image and save it as an indexed open image. +# The returned pointer may be used for header access but not I/O. +# The indexed image is closed by xt_imunmap. + +pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) + +char imname[ARB] #I Image name +int acmode #I Access mode +int hdr_arg #I Header argument +int index #I Save index +int retry #I Retry counter +pointer im #O Image pointer (returned) + +int i, envgeti() +pointer xt, xt_opix() +errchk xt_opix + +int first_time +data first_time /YES/ + +include "xtimmap.com" + +begin + if (acmode != READ_ONLY) + call error (1, "XT_IMMAP: Only READ_ONLY allowed") + + # Set maximum number of open images based on retry. + if (retry > 0) + max_openim = min (1024, MAX_OPENIM) / retry + else + max_openim = MAX_OPENIM + + # Initialize once per process. + if (first_time == YES) { + iferr (option = envgeti ("imcombine_option")) + option = 1 + min_open = 1 + nopen = 0 + nopenpix = 0 + nalloc = max_openim + call calloc (ims, nalloc, TY_POINTER) + first_time = NO + } + + # Free image if needed. + call xt_imunmap (NULL, index) + + # Allocate structure. + if (index > nalloc) { + i = nalloc + nalloc = index + max_openim + call realloc (ims, nalloc, TY_STRUCT) + call amovki (NULL, Memi[ims+i], nalloc-i) + } + call calloc (xt, XT_LEN, TY_STRUCT) + Memi[ims+index-1] = xt + + # Initialize. + call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) + XT_ARG(xt) = hdr_arg + XT_IM(xt) = NULL + XT_HDR(xt) = NULL + + # Open image. + last_flag = 0 + im = xt_opix (NULL, index, 0) + + # Make copy of IMIO pointer for header keyword access. + call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) + call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) + call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) + + return (XT_HDR(xt)) +end + + +# XT_OPIX -- Open the image for I/O. +# If the image has not been mapped return the default pointer. + +pointer procedure xt_opix (imdef, index, flag) + +int index #I index +pointer imdef #I Default pointer +int flag #I Flag + +int i, open(), imstati() +pointer im, xt, xt1, immap() +errchk open, immap, imunmap + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imdef) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_opix imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Return pointer for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (im) + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || flag == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + if (VERBOSE) { + call eprintf ("%d: imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_opix immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + if (!IS_INDEFI(XT_BUFSIZE(xt))) + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + else + XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (im) +end + + +# XT_CPIX -- Close image. + +procedure xt_cpix (index) + +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) + return + + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_cpix imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call imunmap (XT_IM(xt)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + } + call mfree (XT_BUF(xt), XT_BTYPE(xt)) +end + + +# XT_IMSETI -- Set IMIO value. + +procedure xt_imseti (index, param, value) + +int index #I index +int param #I IMSET parameter +int value #I Value + +pointer xt +bool streq() + +include "xtimmap.com" + +begin + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + if (xt == NULL) { + if (streq (param, "option")) + option = value + } else { + if (streq (param, "bufsize")) { + XT_BUFSIZE(xt) = value + if (XT_IM(xt) != NULL) { + call imseti (XT_IM(xt), IM_BUFFRAC, 0) + call imseti (XT_IM(xt), IM_BUFSIZE, value) + } + } + } +end + + +# XT_IMUNMAP -- Unmap indexed open image. +# The header pointer is set to NULL to indicate the image has been closed. + +procedure xt_imunmap (im, index) + +int im #U IMIO header pointer +int index #I index + +pointer xt +errchk imunmap + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) { + if (im != NULL) + call imunmap (im) + return + } + + # Close indexed image. + if (XT_IM(xt) != NULL) { + if (VERBOSE) { + call eprintf ("%d: xt_imunmap imunmap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + iferr (call imunmap (XT_IM(xt))) { + XT_IM(xt) = NULL + call erract (EA_WARN) + } + nopen = nopen - 1 + if (XT_CLOSEFD(xt) == NO) + nopenpix = nopenpix - 1 + if (index == min_open) + min_open = 1 + } + + # Free any buffered memory. + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + + # Free header pointer. Note that if the supplied pointer is not + # header pointer then it is not set to NULL. + if (XT_HDR(xt) == im) + im = NULL + call mfree (XT_HDR(xt), TY_STRUCT) + + # Free save structure. + call mfree (Memi[ims+index-1], TY_STRUCT) + Memi[ims+index-1] = NULL +end + + +# XT_MINHDR -- Minimize header assuming keywords will not be accessed. + +procedure xt_minhdr (index) + +int index #I index + +pointer xt +errchk realloc + +include "xtimmap.com" + +begin + # Check for an indexed image. If it is not unmap the pointer + # as a regular IMIO pointer. + + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + if (xt == NULL) + return + + # Minimize header pointer. + if (VERBOSE) { + call eprintf ("%d: xt_minhdr %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) + if (XT_IM(xt) != NULL) + call realloc (XT_IM(xt), IMU+1, TY_STRUCT) +end + + +# XT_REINDEX -- Reindex open images. +# This is used when some images are closed by xt_imunmap. It is up to +# the calling program to reindex the header pointers and to subsequently +# use the new index values. + +procedure xt_reindex () + +int old, new + +include "xtimmap.com" + +begin + new = 0 + do old = 0, nalloc-1 { + if (Memi[ims+old] == NULL) + next + Memi[ims+new] = Memi[ims+old] + new = new + 1 + } + do old = new, nalloc-1 + Memi[ims+old] = NULL +end + + +$for(sird) +# XT_IMGNL -- Return the next line for the indexed image. +# Possibly unmap another image if too many files are open. +# Buffer data when an image is unmmaped to minimize the mapping of images. +# If the requested index has not been mapped use the default pointer. + +int procedure xt_imgnl$t (imdef, index, buf, v, flag) + +pointer imdef #I Default pointer +int index #I index +pointer buf #O Data buffer +long v[ARB] #I Line vector +int flag #I Flag (=output line) + +int i, j, nc, nl, open(), imgnl$t(), sizeof(), imloop() +pointer im, xt, xt1, ptr, immap(), imggs$t() +errchk open, immap, imgnl$t, imggs$t, imunmap + +long unit_v[IM_MAXDIM] +data unit_v /IM_MAXDIM * 1/ + +include "xtimmap.com" + +begin + # Get index pointer. + xt = NULL + if (index <= nalloc && index > 0) + xt = Memi[ims+index-1] + + # Use default pointer if index has not been mapped. + if (xt == NULL) + return (imgnl$t (imdef, buf, v)) + + # Close images not accessed during previous line. + # In normal usage this should only occur once per line over all + # indexed images. + if (flag != last_flag) { + do i = 1, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL || XT_FLAG(xt1) == last_flag) + next + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + } + + # Optimize the file I/O. + do i = nalloc, 1, -1 { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + min_open = i + if (nopenpix < MAX_OPENPIX) { + if (XT_CLOSEFD(xt1) == NO) + next + XT_CLOSEFD(xt1) = NO + call imseti (im, IM_CLOSEFD, NO) + nopenpix = nopenpix + 1 + } + } + last_flag = flag + } + + # Use IMIO for already opened images. + im = XT_IM(xt) + if (im != NULL) { + XT_FLAG(xt) = flag + return (imgnl$t (im, buf, v)) + } + + # If the image is not currently mapped use the stored header. + im = XT_HDR(xt) + + # Check for EOF. + i = IM_NDIM(im) + if (v[i] > IM_LEN(im,i)) + return (EOF) + + # Check for buffered data. + if (XT_BUF(xt) != NULL) { + if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { + if (XT_BTYPE(xt) != TY_PIXEL) + call error (1, "Cannot mix data types") + nc = IM_LEN(im,1) + buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) + XT_FLAG(xt) = flag + if (i == 1) + v[1] = nc + 1 + else + j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) + return (nc) + } + } + + # Handle more images than the maximum that can be open at one time. + if (nopen >= max_openim) { + if (option == XT_MAPUNMAP || v[2] == 0) { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + im = XT_IM(xt1) + if (im == NULL) + next + + # Buffer some number of lines. + nl = XT_BUFSIZE(xt1) / sizeof (TY_PIXEL) / IM_LEN(im,1) + if (nl > 1) { + nc = IM_LEN(im,1) + call amovl (v, XT_VS(xt1,1), IM_MAXDIM) + call amovl (v, XT_VE(xt1,1), IM_MAXDIM) + XT_VS(xt1,1) = 1 + XT_VE(xt1,1) = nc + XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) + nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 + XT_BTYPE(xt1) = TY_PIXEL + call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) + ptr = imggs$t (im, XT_VS(xt1,1), XT_VE(xt1,1), + IM_NDIM(im)) + call amov$t (Mem$t[ptr], Mem$t[XT_BUF(xt1)], nl*nc) + } + + if (VERBOSE) { + call eprintf ("%d: xt_imgnl imunmap %s\n") + call pargi (i) + call pargstr (XT_IMNAME(xt1)) + } + call imunmap (XT_IM(xt1)) + nopen = nopen - 1 + if (XT_CLOSEFD(xt1) == NO) + nopenpix = nopenpix - 1 + min_open = i + 1 + break + } + if (index <= min_open) + min_open = index + else { + do i = min_open, nalloc { + xt1 = Memi[ims+i-1] + if (xt1 == NULL) + next + if (XT_IM(xt1) == NULL) + next + min_open = i + break + } + } + } else { + # Check here because we can't catch error in immap. + i = open ("dev$null", READ_ONLY, BINARY_FILE) + call close (i) + if (i == LAST_FD - 1) + call error (SYS_FTOOMANYFILES, "Too many open files") + } + } + + # Open image. + if (VERBOSE) { + call eprintf ("%d: xt_imgnl immap %s\n") + call pargi (index) + call pargstr (XT_IMNAME(xt)) + } + im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) + XT_IM(xt) = im + call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) + call mfree (XT_BUF(xt), XT_BTYPE(xt)) + nopen = nopen + 1 + XT_CLOSEFD(xt) = YES + if (nopenpix < MAX_OPENPIX) { + XT_CLOSEFD(xt) = NO + nopenpix = nopenpix + 1 + } + if (XT_CLOSEFD(xt) == YES) + call imseti (im, IM_CLOSEFD, YES) + XT_FLAG(xt) = flag + + return (imgnl$t (im, buf, v)) +end +$endfor diff --git a/pkg/images/immatch/src/imcombine/src/xtprocid.x b/pkg/images/immatch/src/imcombine/src/xtprocid.x new file mode 100644 index 00000000..0a82d81b --- /dev/null +++ b/pkg/images/immatch/src/imcombine/src/xtprocid.x @@ -0,0 +1,38 @@ +# XT_PROCID -- Set or ppdate PROCID keyword. + +procedure xt_procid (im) + +pointer im #I Image header + +int i, j, ver, patmake(), gpatmatch(), strlen(), ctoi() +pointer sp, pat, str + +begin + call smark (sp) + call salloc (pat, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get current ID. + iferr (call imgstr (im, "PROCID", Memc[str], SZ_LINE)) { + iferr (call imgstr (im, "OBSID", Memc[str], SZ_LINE)) { + call sfree (sp) + return + } + } + + # Set new PROCID. + ver = 0 + i = patmake ("V[0-9]*$", Memc[pat], SZ_LINE) + if (gpatmatch (Memc[str], Memc[pat], i, j) == 0) + ; + if (j > 0) { + j = i+1 + if (ctoi (Memc[str], j, ver) == 0) + ver = 0 + i = i - 1 + } else + i = strlen (Memc[str]) + call sprintf (Memc[str+i], SZ_LINE, "V%d") + call pargi (ver+1) + call imastr (im, "PROCID", Memc[str]) +end diff --git a/pkg/images/immatch/src/imcombine/t_imcombine.x b/pkg/images/immatch/src/imcombine/t_imcombine.x new file mode 100644 index 00000000..d3774958 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/t_imcombine.x @@ -0,0 +1,230 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "src/icombine.h" + + +# T_IMCOMBINE - This task combines a list of images into an output image +# and an optional sigma image. There are many combining options from +# which to choose. + +procedure t_imcombine () + +pointer sp, fname, output, headers, bmask, rmask, sigma, nrmask, emask, logfile +pointer scales, zeros, wts, im +int n, input, ilist, olist, hlist, blist, rlist, slist, nrlist, elist + +bool clgetb() +real clgetr() +int clgwrd(), clgeti(), imtopenp(), imtopen(), imtgetim(), imtlen() +pointer immap() +errchk immap, icombine + +include "src/icombine.com" + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (headers, SZ_FNAME, TY_CHAR) + call salloc (bmask, SZ_FNAME, TY_CHAR) + call salloc (rmask, SZ_FNAME, TY_CHAR) + call salloc (nrmask, SZ_FNAME, TY_CHAR) + call salloc (emask, SZ_FNAME, TY_CHAR) + call salloc (sigma, SZ_FNAME, TY_CHAR) + call salloc (expkeyword, SZ_FNAME, TY_CHAR) + call salloc (statsec, SZ_FNAME, TY_CHAR) + call salloc (gain, SZ_FNAME, TY_CHAR) + call salloc (rdnoise, SZ_FNAME, TY_CHAR) + call salloc (snoise, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + + # Get task parameters. Some additional parameters are obtained later. + ilist = imtopenp ("input") + olist = imtopenp ("output") + hlist = imtopenp ("headers") + blist = imtopenp ("bpmasks") + rlist = imtopenp ("rejmasks") + nrlist = imtopenp ("nrejmasks") + elist = imtopenp ("expmasks") + slist = imtopenp ("sigmas") + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + + project = clgetb ("project") + combine = clgwrd ("combine", Memc[fname], SZ_FNAME, COMBINE) + if (combine == MEDIAN || combine == LMEDIAN) { + if (combine == MEDIAN) + medtype = MEDAVG + else { + medtype = MEDLOW + combine = MEDIAN + } + } + reject = clgwrd ("reject", Memc[fname], SZ_FNAME, REJECT) + blank = clgetr ("blank") + call clgstr ("expname", Memc[expkeyword], SZ_FNAME) + call clgstr ("statsec", Memc[statsec], SZ_FNAME) + call clgstr ("gain", Memc[gain], SZ_FNAME) + call clgstr ("rdnoise", Memc[rdnoise], SZ_FNAME) + call clgstr ("snoise", Memc[snoise], SZ_FNAME) + lthresh = clgetr ("lthreshold") + hthresh = clgetr ("hthreshold") + lsigma = clgetr ("lsigma") + hsigma = clgetr ("hsigma") + pclip = clgetr ("pclip") + flow = clgetr ("nlow") + fhigh = clgetr ("nhigh") + nkeep = clgeti ("nkeep") + grow = clgetr ("grow") + mclip = clgetb ("mclip") + sigscale = clgetr ("sigscale") + verbose = false + + # Check lists. + n = imtlen (ilist) + if (n == 0) + call error (1, "No input images to combine") + + if (project) { + if (imtlen (olist) != n) + call error (1, "Wrong number of output images") + if (imtlen (hlist) != 0 && imtlen (hlist) != n) + call error (1, "Wrong number of header files") + if (imtlen (blist) != 0 && imtlen (blist) != n) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) != 0 && imtlen (rlist) != n) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 0 && imtlen (nrlist) != n) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 0 && imtlen (elist) != n) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 0 && imtlen (slist) != n) + call error (1, "Wrong number of sigma images") + } else { + if (imtlen (olist) != 1) + call error (1, "Wrong number of output images") + if (imtlen (hlist) > 1) + call error (1, "Wrong number of header files") + if (imtlen (blist) > 1) + call error (1, "Wrong number of bad pixel masks") + if (imtlen (rlist) > 1) + call error (1, "Wrong number of rejection masks") + if (imtlen (nrlist) > 1) + call error (1, "Wrong number of number rejected masks") + if (imtlen (elist) > 1) + call error (1, "Wrong number of exposure masks") + if (imtlen (slist) > 1) + call error (1, "Wrong number of sigma images") + } + + # Check parameters, map INDEFs, and set threshold flag + if (pclip == 0. && reject == PCLIP) + call error (1, "Pclip parameter may not be zero") + if (IS_INDEFR (blank)) + blank = 0. + if (IS_INDEFR (lsigma)) + lsigma = MAX_REAL + if (IS_INDEFR (hsigma)) + hsigma = MAX_REAL + if (IS_INDEFR (pclip)) + pclip = -0.5 + if (IS_INDEFR (flow)) + flow = 0 + if (IS_INDEFR (fhigh)) + fhigh = 0 + if (IS_INDEFR (grow)) + grow = 0. + if (IS_INDEF (sigscale)) + sigscale = 0. + + if (IS_INDEF(lthresh) && IS_INDEF(hthresh)) + dothresh = false + else { + dothresh = true + if (IS_INDEF(lthresh)) + lthresh = -MAX_REAL + if (IS_INDEF(hthresh)) + hthresh = MAX_REAL + } + + # Loop through image lists. + while (imtgetim (ilist, Memc[fname], SZ_FNAME) != EOF) { + iferr { + scales = NULL; input = ilist + + if (imtgetim (olist, Memc[output], SZ_FNAME) == EOF) { + if (project) { + call sprintf (Memc[output], SZ_FNAME, + "IMCOMBINE: No output image for %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } else + call error (1, "IMCOMBINE: No output image") + } + if (imtgetim (hlist, Memc[headers], SZ_FNAME) == EOF) + Memc[headers] = EOS + if (imtgetim (blist, Memc[bmask], SZ_FNAME) == EOF) + Memc[bmask] = EOS + if (imtgetim (rlist, Memc[rmask], SZ_FNAME) == EOF) + Memc[rmask] = EOS + if (imtgetim (nrlist, Memc[nrmask], SZ_FNAME) == EOF) + Memc[nrmask] = EOS + if (imtgetim (elist, Memc[emask], SZ_FNAME) == EOF) + Memc[emask] = EOS + if (imtgetim (slist, Memc[sigma], SZ_FNAME) == EOF) + Memc[sigma] = EOS + + # Set the input list and initialize the scaling factors. + if (project) { + im = immap (Memc[fname], READ_ONLY, 0) + if (IM_NDIM(im) == 1) + n = 0 + else + n = IM_LEN(im,IM_NDIM(im)) + call imunmap (im) + if (n == 0) { + call sprintf (Memc[output], SZ_FNAME, + "IMCOMBINE: Can't project one dimensional image %s") + call pargstr (Memc[fname]) + call error (1, Memc[output]) + } + input = imtopen (Memc[fname]) + } else { + call imtrew (ilist) + n = imtlen (ilist) + input = ilist + } + + # Allocate and initialize scaling factors. + call malloc (scales, 3*n, TY_REAL) + zeros = scales + n + wts = scales + 2 * n + call amovkr (INDEFR, Memr[scales], 3*n) + + call icombine (input, Memc[output], Memc[headers], Memc[bmask], + Memc[rmask], Memc[nrmask], Memc[emask], Memc[sigma], + Memc[logfile], Memr[scales], Memr[zeros], Memr[wts], + NO, NO, NO) + + } then + call erract (EA_WARN) + + if (input != ilist) + call imtclose (input) + call mfree (scales, TY_REAL) + if (!project) + break + } + + call imtclose (ilist) + call imtclose (olist) + call imtclose (hlist) + call imtclose (blist) + call imtclose (rlist) + call imtclose (nrlist) + call imtclose (elist) + call imtclose (slist) + call sfree (sp) +end diff --git a/pkg/images/immatch/src/imcombine/x_imcombine.x b/pkg/images/immatch/src/imcombine/x_imcombine.x new file mode 100644 index 00000000..a85e34f6 --- /dev/null +++ b/pkg/images/immatch/src/imcombine/x_imcombine.x @@ -0,0 +1 @@ +task imcombine = t_imcombine diff --git a/pkg/images/immatch/src/linmatch/linmatch.h b/pkg/images/immatch/src/linmatch/linmatch.h new file mode 100644 index 00000000..0f776901 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/linmatch.h @@ -0,0 +1,298 @@ +# Header file for LINSCALE + +define LEN_LSSTRUCT (70 + 12 * SZ_FNAME + 12) + +# Quantities that define the current region and the number of regions + +define LS_CNREGION Memi[$1] # the current region +define LS_NREGIONS Memi[$1+1] # the number of regions +define LS_MAXNREGIONS Memi[$1+2] # the maximum number of regions + +# Quantities that are dependent on the number of regions + +define LS_RC1 Memi[$1+3] # pointers to first columns of regions +define LS_RC2 Memi[$1+4] # pointers to last columns of regions +define LS_RL1 Memi[$1+5] # pointer to first lines of regions +define LS_RL2 Memi[$1+6] # pointers to last lines of regions +define LS_RXSTEP Memi[$1+7] # pointers to the x step sizes +define LS_RYSTEP Memi[$1+8] # pointers to the y step sizes +define LS_XSHIFT Memr[P2R($1+9)] # the x shift from image to reference +define LS_YSHIFT Memr[P2R($1+10)] # the y shift from image to reference +define LS_SXSHIFT Memr[P2R($1+11)] # the x shift from image to reference +define LS_SYSHIFT Memr[P2R($1+12)] # the y shift from image to reference + +define LS_RBUF Memi[$1+14] # pointer to the reference image data +define LS_RGAIN Memr[P2R($1+15)] # the reference image gain +define LS_RREADNOISE Memr[P2R($1+16)] # the reference image readout noise +define LS_RMEAN Memi[$1+17] # pointers to means of ref regions +define LS_RMEDIAN Memi[$1+18] # pointers to medians of ref regions +define LS_RMODE Memi[$1+19] # pointers to modes of ref regions +define LS_RSIGMA Memi[$1+20] # pointers to stdevs of ref regions +define LS_RSKY Memi[$1+21] # pointers to sky values of ref regions +define LS_RSKYERR Memi[$1+22] # pointers to sky errors of ref regions +define LS_RMAG Memi[$1+23] # pointers to magnitudes of ref regions +define LS_RMAGERR Memi[$1+24] # pointers to mag errors of ref regions +define LS_RNPTS Memi[$1+25] # pointers to npts of ref regions + +define LS_IBUF Memi[$1+27] # pointer to the input image data +define LS_IGAIN Memr[P2R($1+28)] # the input image gain +define LS_IREADNOISE Memr[P2R($1+29)] # the input image readout noise +define LS_IMEAN Memi[$1+30] # pointers to means of image regions +define LS_IMEDIAN Memi[$1+31] # pointers to medians of image regions +define LS_IMODE Memi[$1+32] # pointers to modes of image regions +define LS_ISIGMA Memi[$1+33] # pointers to stdevs of image regions +define LS_ISKY Memi[$1+34] # pointers to sky values of image regions +define LS_ISKYERR Memi[$1+35] # pointers to sky errors of image regions +define LS_IMAG Memi[$1+36] # pointers to magnitudes of image regions +define LS_IMAGERR Memi[$1+37] # pointers to mag errors of image regions +define LS_INPTS Memi[$1+38] # pointers to npts of image regions + +define LS_RBSCALE Memi[$1+39] # pointers to bscales of regions +define LS_RBSCALEERR Memi[$1+40] # pointers to bscale errors of regions +define LS_RBZERO Memi[$1+41] # pointers to bzero errors of regions +define LS_RBZEROERR Memi[$1+42] # pointers to bzero errors of regions +define LS_RDELETE Memi[$1+43] # pointer to the delete array +define LS_RCHI Memi[$1+44] # pointer to the resid array + +# Quantities that affect the fitting algorithms + +define LS_BSALGORITHM Memi[$1+45] # bscale fitting algorithm +define LS_BZALGORITHM Memi[$1+46] # bzero fitting algorithm +define LS_CBZERO Memr[P2R($1+47)] # constant bzero +define LS_CBSCALE Memr[P2R($1+48)] # constant bscale +define LS_DNX Memi[$1+49] # x width of data region to extract +define LS_DNY Memi[$1+50] # y width of data region to extract +#define LS_PNX Memi[$1+51] # x width of photometry region +#define LS_PNY Memi[$1+52] # y widht of photometry region +define LS_DATAMIN Memr[P2R($1+51)] # the minimum good data value +define LS_DATAMAX Memr[P2R($1+52)] # the maximum good data value +define LS_MAXITER Memi[$1+53] # maximum number of iterations +define LS_NREJECT Memi[$1+54] # maximum number of rejections cycles +define LS_LOREJECT Memr[P2R($1+55)] # low-side sigma rejection criterion +define LS_HIREJECT Memr[P2R($1+56)] # high-side sigma rejection criterion +define LS_GAIN Memr[P2R($1+57)] # the constant gain value in e-/adu +define LS_READNOISE Memr[P2R($1+58)] # the constant readout noise value in e- + +# Quantities that define the answers + +define LS_TBSCALE Memr[P2R($1+59)] # bzero value +define LS_TBSCALEERR Memr[P2R($1+60)] # bscale error estimate +define LS_TBZERO Memr[P2R($1+61)] # bzero value +define LS_TBZEROERR Memr[P2R($1+62)] # bzero error estimate + +# String quantities + +define LS_BSSTRING Memc[P2C($1+65)] # bscale string +define LS_BZSTRING Memc[P2C($1+65+SZ_FNAME+1)] # bzero string +define LS_CCDGAIN Memc[P2C($1+65+2*SZ_FNAME+2)] # gain keyword +define LS_CCDREAD Memc[P2C($1+65+3*SZ_FNAME+3)] # readout noise keyword +define LS_IMAGE Memc[P2C($1+65+4*SZ_FNAME+4)] # input image +define LS_REFIMAGE Memc[P2C($1+65+5*SZ_FNAME+5)] # reference image +define LS_REGIONS Memc[P2C($1+65+6*SZ_FNAME+6)] # regions list +define LS_DATABASE Memc[P2C($1+65+7*SZ_FNAME+7)] # database file +define LS_OUTIMAGE Memc[P2C($1+65+8*SZ_FNAME+8)] # output image +define LS_SHIFTSFILE Memc[P2C($1+65+9*SZ_FNAME+9)] # shifts file +define LS_PHOTFILE Memc[P2C($1+65+10*SZ_FNAME+10)] # shifts file +define LS_RECORD Memc[P2C($1+65+11*SZ_FNAME+11)] # the record name + + +# Define the bzero and bscale fitting algorithms + +define LS_MEAN 1 +define LS_MEDIAN 2 +define LS_MODE 3 +define LS_FIT 4 +define LS_PHOTOMETRY 5 +define LS_FILE 6 +define LS_NUMBER 7 + +define LS_SCALING "|mean|median|mode|fit|photometry|file|" + +# Define the parameters + +define CNREGION 1 +define NREGIONS 2 +define MAXNREGIONS 3 + +define RC1 4 +define RC2 5 +define RL1 6 +define RL2 7 +define RXSTEP 8 +define RYSTEP 9 +define XSHIFT 10 +define YSHIFT 11 +define SXSHIFT 12 +define SYSHIFT 13 + +define RBUF 14 +define RGAIN 15 +define RREADNOISE 16 +define RMEAN 17 +define RMEDIAN 18 +define RMODE 19 +define RSIGMA 20 +define RSKY 21 +define RSKYERR 22 +define RMAG 23 +define RMAGERR 24 +define RNPTS 25 + +define IBUF 26 +define IGAIN 27 +define IREADNOISE 28 +define IMEAN 29 +define IMEDIAN 30 +define IMODE 31 +define ISIGMA 32 +define ISKY 33 +define ISKYERR 34 +define IMAG 35 +define IMAGERR 36 +define INPTS 37 + +define RBSCALE 38 +define RBSCALEERR 39 +define RBZERO 40 +define RBZEROERR 41 +define RDELETE 42 +define RCHI 43 + +define BZALGORITHM 44 +define BSALGORITHM 45 +define CBZERO 46 +define CBSCALE 47 +define DNX 48 +define DNY 49 +#define PNX 50 +#define PNY 51 +define DATAMIN 50 +define DATAMAX 51 +define MAXITER 52 + +define NREJECT 53 +define LOREJECT 54 +define HIREJECT 55 +define GAIN 56 +define READNOISE 57 + +define TBZERO 58 +define TBZEROERR 59 +define TBSCALE 60 +define TBSCALEERR 61 + +define BSSTRING 62 +define BZSTRING 63 +define CCDGAIN 64 +define CCDREAD 65 + +define IMAGE 66 +define REFIMAGE 67 +define REGIONS 68 +define DATABASE 69 +define OUTIMAGE 70 +define RECORD 71 +define SHIFTSFILE 72 +define PHOTFILE 73 + +# Set some default values + +define DEF_MAXNREGIONS 100 +define DEF_BZALGORITHM LS_FIT +define DEF_BSALGORITHM LS_FIT +define DEF_CBZERO 0.0 +define DEF_CBSCALE 1.0 +define DEF_DNX 31 +define DEF_DNY 31 +define DEF_MAXITER 10 +define DEF_DATAMIN INDEFR +define DEF_DATAMAX INDEFR +define DEF_NREJECT 0 +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR +define DEF_GAIN INDEFR +define DEF_READNOISE INDEFR + +# The mode computation parameters. + +define LMODE_NMIN 10 +define LMODE_ZRANGE 1.0 +define LMODE_ZBIN 0.1 +define LMODE_ZSTEP 0.01 +define LMODE_HWIDTH 3.0 + +# The default plot types. + +define LS_MMHIST 1 +define LS_MMFIT 2 +define LS_MMRESID 3 +define LS_RIFIT 4 +define LS_RIRESID 5 +define LS_BSZFIT 6 +define LS_BSZRESID 7 +define LS_MAGSKYFIT 8 +define LS_MAGSKYRESID 9 + +# The bad point deletions code. + +define LS_NO 0 +define LS_BADREGION 1 +define LS_BADSIGMA 2 +define LS_DELETED 3 + +# Commands + +define LSCMDS "|input|reference|regions|lintransform|output|photfile|\ +shifts|records|xshift|yshift|dnx|dny|maxnregions|datamin|datamax|\ +maxiter|nreject|loreject|hireject|gain|readnoise|show|markcoords|marksections|" + +define LSCMD_IMAGE 1 +define LSCMD_REFIMAGE 2 +define LSCMD_REGIONS 3 +define LSCMD_DATABASE 4 +define LSCMD_OUTIMAGE 5 +define LSCMD_PHOTFILE 6 +define LSCMD_SHIFTSFILE 7 +define LSCMD_RECORD 8 +define LSCMD_XSHIFT 9 +define LSCMD_YSHIFT 10 +define LSCMD_DNX 11 +define LSCMD_DNY 12 +define LSCMD_MAXNREGIONS 13 +define LSCMD_DATAMIN 14 +define LSCMD_DATAMAX 15 +define LSCMD_MAXITER 16 +define LSCMD_NREJECT 17 +define LSCMD_LOREJECT 18 +define LSCMD_HIREJECT 19 +define LSCMD_GAIN 20 +define LSCMD_READNOISE 21 +define LSCMD_SHOW 22 +define LSCMD_MARKCOORDS 23 +define LSCMD_MARKSECTIONS 24 + +# Keywords + +define KY_REFIMAGE "reference" +define KY_IMAGE "input" +define KY_REGIONS "regions" +define KY_DATABASE "lintransform" +define KY_OUTIMAGE "output" +define KY_PHOTFILE "photfile" +define KY_SHIFTSFILE "shifts" +define KY_RECORD "records" +define KY_XSHIFT "xshift" +define KY_YSHIFT "yshift" +define KY_DNX "dnx" +define KY_DNY "dny" +define KY_MAXNREGIONS "maxnregions" +define KY_DATAMIN "datamin" +define KY_DATAMAX "datamax" +define KY_MAXITER "maxiter" +define KY_NREJECT "nreject" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_GAIN "gain" +define KY_READNOISE "readnoise" +define KY_NREGIONS "nregions" + diff --git a/pkg/images/immatch/src/linmatch/linmatch.key b/pkg/images/immatch/src/linmatch/linmatch.key new file mode 100644 index 00000000..824f6b26 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/linmatch.key @@ -0,0 +1,51 @@ + Interactive Keystroke Commands + +? Print help +: Colon commands + +g Draw a plot of the current fit +i Draw the residuals plot for the current fit +p Draw a plot of current photometry +s Draw histograms for the image region nearest the cursor +l Draw the least squares fit for the image region nearest the cursor +h Draw histogram plot of each image region in turn +l Draw least squares fits plot of each image region in turn +r Redraw the current plot +d Delete the image region nearest the cursor +u Undelete the image region nearest the cursor +f Recompute the intensity matching function +w Update the task parameters +q Exit + + + Colon Commands + +:markcoords Mark objects on the display +:marksections Mark image sections on the display +:show Show current values of all the parameters + + Show/set Parameters + +:input [string] Show/set the current input image +:reference [string] Show/set the current reference image / phot file +:regions [string] Show/set the current image regions +:photfile [string] Show/set the current input photometry file +:lintransform [string] Show/set the linear transform database file name +:dnx [value] Show/set the default x size of an image region +:dny [value] Show/set the default y size of an image region +:shifts [string] Show/set the current shifts file +:xshift [value] Show/set the input image x shift +:yshift [value] Show/set the input image y shift +:output [string] Show/set the current output image name +:maxnregions Show the maximum number of objects / regions +:gain [string] Show/set the gain value / image header keyword +:readnoise [string] Show/set the readout noise value / image header + keyword + +:scaling Show the current scaling algorithm +:datamin [value] Show/set the minimum good data value +:datamax [value] Show/set the maximum good data value +:nreject [value] Show/set the maximum number of rejection cycles +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter + diff --git a/pkg/images/immatch/src/linmatch/lsqfit.h b/pkg/images/immatch/src/linmatch/lsqfit.h new file mode 100644 index 00000000..69691935 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/lsqfit.h @@ -0,0 +1,18 @@ +# The definitions file for the least squares fitting routines. + +define MAX_NFITPARS 7 # number of parameters following + +define YINCPT $1[1] # y-intercept +define EYINCPT $1[2] # error in y-intercept +define SLOPE $1[3] # slope of fit +define ESLOPE $1[4] # error in slope +define CHI $1[5] # mean error of unit weight +define RMS $1[6] # mean error of unit weight + +#define ME1 $1[1] # mean error of unit weight +#define OFFSET $1[2] # intercept +#define EOFFSET $1[3] # error in intercept +#define SLOPE1 $1[4] # slope of fit to first variable +#define ESLOPE1 $1[5] # error in slope1 +#define SLOPE2 $1[6] # slope of fit to second variable +#define ESLOPE2 $1[7] # error in slope2 diff --git a/pkg/images/immatch/src/linmatch/mkpkg b/pkg/images/immatch/src/linmatch/mkpkg new file mode 100644 index 00000000..5a8894f2 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/mkpkg @@ -0,0 +1,21 @@ +# Make the LINMATCH task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rglcolon.x linmatch.h + rgldbio.x linmatch.h + rgldelete.x linmatch.h + rgliscale.x linmatch.h + rglpars.x linmatch.h + rglplot.x linmatch.h + rglregions.x linmatch.h + rglscale.x linmatch.h lsqfit.h + rglshow.x linmatch.h + rglsqfit.x lsqfit.h + rgltools.x linmatch.h + t_linmatch.x linmatch.h + ; diff --git a/pkg/images/immatch/src/linmatch/rglcolon.x b/pkg/images/immatch/src/linmatch/rglcolon.x new file mode 100644 index 00000000..8c1d48ef --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglcolon.x @@ -0,0 +1,564 @@ +include +include +include "linmatch.h" + +# RG_LCOLON -- Show/set the linmatch task algorithm parameters. + +procedure rg_lcolon (gd, ls, imr, im1, im2, db, dformat, reglist, rpfd, ipfd, + sfd, cmdstr, newref, newimage, newfit, newavg) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to linmatch structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +pointer db #I pointer to the databas file +int dformat #I the database file format +int reglist #I the regions / photometry file descriptor +int rpfd #I the reference photometry file descriptor +int ipfd #I the input photometry file descriptor +int sfd #I the shifts file descriptor +char cmdstr[ARB] #I command string +int newref #I/O new reference image +int newimage #I/O new input image +int newfit #I/O new fit +int newavg #I/O new averages + +int ncmd, nref, nim, ival, fd +pointer sp, cmd, str +real rval +bool streq() +int strdic(), rg_lstati(), rg_lregions(), open(), fntopnb(), nscan() +int rg_lrphot(), access(), rg_lmkxy(), rg_lmkregions() +pointer immap(), dtmap() +real rg_lstatr() +errchk immap(), open(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, LSCMDS) + + switch (ncmd) { + + case LSCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else if (rg_lstati(ls, BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY) { + if (rpfd != NULL) { + call close (rpfd) + rpfd = NULL + } + iferr { + rpfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + if (rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) <= 0) + ; + call seek (ipfd, BOF) + if (rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) <= 0) + ; + } else { + nref = rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) + if (nref > 0) { + call seek (ipfd, BOF) + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + if (nim < nref) + call printf ("There are too few input points\n") + } else { + call close (rpfd) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + if (rg_lrphot (rpfd, ls, 1, rg_lstati(ls, MAXNREGIONS), + YES) <= 0) + ; + call seek (ipfd, BOF) + if (rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) <= 0) + ; + call printf ( + "The new reference photometry file is empty\n") + } + call rg_lsets (ls, REFIMAGE, Memc[cmd]) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, REFIMAGE, Memc[cmd]) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_IMAGE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, IMAGE, Memc[cmd]) + newimage = YES; newref = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_REGIONS: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, REGIONS, Memc[str], SZ_FNAME) + if (reglist == NULL || nscan() == 1 || (streq (Memc[cmd], + Memc[str]) && Memc[cmd] != EOS)) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + } else if (rg_lstati(ls, BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls, BZALGORITHM) != LS_PHOTOMETRY) { + call fntclsb (reglist) + iferr { + reglist = fntopnb (Memc[cmd], NO) + } then { + reglist = fntopnb (Memc[str], NO) + } else { + if (rg_lregions (reglist, imr, ls, 1, NO) > 0) + ; + call rg_lsets (ls, REGIONS, Memc[cmd]) + newimage = YES; newref = YES; newfit = YES; newavg = YES + } + } + + case LSCMD_PHOTFILE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, PHOTFILE, Memc[str], SZ_FNAME) + if (ipfd == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_PHOTFILE) + call pargstr (Memc[str]) + } else { + if (ipfd != NULL) { + call close (ipfd) + ipfd = NULL + } + iferr { + ipfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } else { + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + if (nim > 0) { + call rg_lsets (ls, PHOTFILE, Memc[cmd]) + newref = YES; newimage = YES + newfit = YES; newavg = YES + } else { + call close (ipfd) + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + nim = rg_lrphot (ipfd, ls, 1, rg_lstati(ls, NREGIONS), + NO) + } + } + } + + case LSCMD_SHIFTSFILE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, SHIFTSFILE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_SHIFTSFILE) + call pargstr (Memc[str]) + } else { + if (sfd != NULL) { + call close (sfd) + sfd = NULL + } + iferr { + sfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + call erract (EA_WARN) + sfd = open (Memc[str], READ_ONLY, sfd) + } else { + call rg_lgshift (sfd, ls) + call rg_lstats (ls, SHIFTSFILE, Memc[cmd], SZ_FNAME) + } + } + + case LSCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_lsets (ls, OUTIMAGE, Memc[cmd]) + } + } + + case LSCMD_DATABASE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_lstats (ls, DATABASE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + } else { + if (db != NULL) { + if (dformat == YES) + call dtunmap (db) + else + call close (db) + db = NULL + } + iferr { + if (dformat == YES) + db = dtmap (Memc[cmd], APPEND) + else + db = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } then { + call erract (EA_WARN) + if (dformat == YES) + db = dtmap (Memc[str], APPEND) + else + db = open (Memc[str], APPEND, TEXT_FILE) + } else { + call rg_lsets (ls, DATABASE, Memc[cmd]) + } + } + + CASE LSCMD_RECORD: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, RECORD, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + } else + call rg_lsets (ls, RECORD, Memc[cmd]) + + case LSCMD_XSHIFT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_XSHIFT) + call pargr (rg_lstatr (ls, XSHIFT)) + } else { + call rg_lsetr (ls, XSHIFT, rval) + if (sfd == NULL) { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_YSHIFT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_YSHIFT) + call pargr (rg_lstatr (ls, YSHIFT)) + } else { + call rg_lsetr (ls, YSHIFT, rval) + if (sfd == NULL) { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_DNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DNX) + call pargi (rg_lstati (ls, DNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_lseti (ls, DNX, ival) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_DNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DNY) + call pargi (rg_lstati (ls, DNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_lseti (ls, DNY, ival) + newref = YES; newimage = YES; newfit = YES; newavg = YES + } + + case LSCMD_MAXNREGIONS: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_MAXNREGIONS) + call pargi (rg_lstati (ls, MAXNREGIONS)) + } + + case LSCMD_DATAMIN: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DATAMIN) + call pargr (rg_lstatr (ls, DATAMIN)) + } else { + call rg_lsetr (ls, DATAMIN, rval) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) + newfit = YES; newavg = YES + } + + case LSCMD_DATAMAX: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DATAMAX) + call pargr (rg_lstatr (ls, DATAMAX)) + } else { + call rg_lsetr (ls, DATAMAX, rval) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) + newfit = YES; newavg = YES + } + + case LSCMD_MAXITER: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_MAXITER) + call pargi (rg_lstati (ls, MAXITER)) + } else { + call rg_lseti (ls, MAXITER, ival) + if (rg_lstati(ls,BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls,BZALGORITHM) != LS_PHOTOMETRY) { + if (rg_lstati(ls,BSALGORITHM) == LS_FIT && + rg_lstati(ls,BZALGORITHM) == LS_FIT) { + newfit = YES; newavg = YES + } else + newavg = YES + } + } + + case LSCMD_NREJECT: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_NREJECT) + call pargi (rg_lstati (ls, NREJECT)) + } else { + call rg_lseti (ls, NREJECT, ival) + newfit = YES; newavg = YES + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_lstatr (ls, LOREJECT)) + } else { + call rg_lsetr (ls, LOREJECT, rval) + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_lstatr (ls, HIREJECT)) + } else { + call rg_lsetr (ls, HIREJECT, rval) + if (rg_lstati(ls,BSALGORITHM) == LS_FIT || + rg_lstati(ls,BZALGORITHM) == LS_FIT) + newfit = YES + newavg = YES + } + + case LSCMD_GAIN: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, CCDGAIN, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_GAIN) + call pargstr (Memc[str]) + } else { + call rg_lsets (ls, CCDGAIN, Memc[cmd]) + if (imr != NULL) { + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr(ls,GAIN)) + } + if (im1 != NULL) { + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr(ls,GAIN)) + } + newfit = YES; newavg = YES + } + + case LSCMD_READNOISE: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_lstats (ls, CCDREAD, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_READNOISE) + call pargstr (Memc[str]) + } else { + call rg_lsets (ls, CCDREAD, Memc[cmd]) + if (imr != NULL) { + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr(ls,READNOISE)) + } + if (im1 != NULL) { + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr(ls,READNOISE)) + } + newfit = YES; newavg = YES + } + + case LSCMD_SHOW: + call gdeactivate (gd, 0) + call rg_lshow (ls) + call greactivate (gd, 0) + + case LSCMD_MARKCOORDS, LSCMD_MARKSECTIONS: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + fd = NULL + } else if (access (Memc[cmd], 0, 0) == YES) { + call printf ("Warning: file %s already exists\n") + call pargstr (Memc[cmd]) + fd = NULL + } else { + fd = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } + call printf ("\n") + if (imr == NULL || im1 == NULL) { + call printf ("The reference or input image is undefined.\n") + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + if (ncmd == LSCMD_MARKCOORDS) { + nref = rg_lmkxy (fd, imr, ls, 1, rg_lstati (ls, + MAXNREGIONS)) + } else { + nref = rg_lmkregions (fd, imr, ls, 1, rg_lstati (ls, + MAXNREGIONS), Memc[str], SZ_LINE) + } + if (nref <= 0) { + call rg_lstats (ls, REGIONS, Memc[str], SZ_LINE) + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_lregions (reglist, imr, ls, 1, 1) > 0) + ; + call rg_lsets (ls, REGIONS, Memc[str]) + call rg_lseti (ls, CNREGION, 1) + } else { + call rg_lseti (ls, CNREGION, 1) + call rg_lsets (ls, REGIONS, Memc[str]) + newref = YES; newimage = YES + newfit = YES; newavg = YES + } + } + call printf ("\n") + if (fd != NULL) + call close (fd) + call greactivate (gd, 0) + + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rgldbio.x b/pkg/images/immatch/src/linmatch/rgldbio.x new file mode 100644 index 00000000..63876985 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgldbio.x @@ -0,0 +1,225 @@ +include "linmatch.h" + +# RG_LWREC -- Procedure to write out the entire record. + +procedure rg_lwrec (db, dformat, ls) + +pointer db #I pointer to the database file +int dformat #I is the scaling file in database format +pointer ls #I pointer to the linmatch structure + +pointer sp, image +real rg_lstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + if (dformat == YES) { + call rg_ldbparams (db, ls) + call rg_lwreg (db, ls) + call rg_ldbtscale (db, ls) + } else { + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + call fprintf (db, "%s %g %g %g %g") + call pargstr (Memc[image]) + call pargr (rg_lstatr(ls, TBSCALE)) + call pargr (rg_lstatr(ls, TBZERO)) + call pargr (rg_lstatr(ls, TBSCALEERR)) + call pargr (rg_lstatr(ls, TBZEROERR)) + } + + call sfree (sp) +end + + +# RG_LWREG -- Write out the results for each region. + +procedure rg_lwreg (db, ls) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity matching structure + +int i, nregions, rc1, rc2, rl1, rl2, c1, c2, l1, l2, del +real xshift, yshift, bscale, bzero, bserr, bzerr +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + xshift = rg_lstatr (ls, SXSHIFT) + yshift = rg_lstatr (ls, SYSHIFT) + + nregions = rg_lstati (ls, NREGIONS) + do i = 1, nregions { + + rc1 = Memi[rg_lstatp (ls, RC1)+i-1] + rc2 = Memi[rg_lstatp (ls, RC2)+i-1] + rl1 = Memi[rg_lstatp (ls, RL1)+i-1] + rl2 = Memi[rg_lstatp (ls, RL2)+i-1] + if (IS_INDEFI(rc1)) + c1 = INDEFI + else + c1 = rc1 + xshift + if (IS_INDEFI(rc2)) + c2 = INDEFI + else + c2 = rc2 + xshift + if (IS_INDEFI(rl1)) + l1 = INDEFI + else + l1 = rl1 + yshift + if (IS_INDEFI(rl2)) + l2 = INDEFI + else + l2 = rl2 + yshift + + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + del = Memi[rg_lstatp(ls,RDELETE)+i-1] + + call rg_ldbscaler (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, + bscale, bzero, bserr, bzerr, del) + } +end + + +# RG_LDBPARAMS -- Write the intensity matching parameters to the database file. + +procedure rg_ldbparams (db, ls) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity matching structure + +pointer sp, str +int rg_lstati() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Write out the time record was written. + call dtput (db, "\n") + call dtptime (db) + + # Write out the record name. + call rg_lstats (ls, RECORD, Memc[str], SZ_FNAME) + call dtput (db, "begin\t%s\n") + call pargstr (Memc[str]) + + # Write the image names. + call rg_lstats (ls, IMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t\t%s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t%s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + + call dtput (db, "\t%s\t%d\n") + call pargstr (KY_NREGIONS) + call pargi (rg_lstati(ls, NREGIONS)) + + call sfree (sp) +end + + +# RG_LDBSCALER -- Write the scaling parameters for each region + +procedure rg_ldbscaler (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, bscale, + bzero, bserr, bzerr, del) + +pointer db # pointer to the database file +int rc1, rc2 # reference image region column limits +int rl1, rl2 # reference image region line limits +int c1, c2 # image region column limits +int l1, l2 # image region line limits +real bscale # the scaling parameter +real bzero # the offset parameter +real bserr # the error in the scaling parameter +real bzerr # the error in the offset parameter +int del # the deletions index + +begin + if (IS_INDEFI(rc1) || IS_INDEFI(c1)) { + call dtput (db,"\t[INDEF] [INDEF] %g %g %g %g %s\n") + } else { + call dtput (db,"\t[%d:%d,%d:%d] [%d:%d,%d:%d] %g %g %g %g %s\n") + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + } + + call pargr (bscale) + call pargr (bzero) + call pargr (bserr) + call pargr (bzerr) + if (del == NO) + call pargstr ("") + else + call pargstr ("[Rejected/Deleted]") +end + + +# RG_LDBTSCALE -- Write the final scaling parameters and their errors. + +procedure rg_ldbtscale (db, ls) + +pointer db #I pointer to the text database file +pointer ls #I pointer to the linmatch structure + +real rg_lstatr() + +begin + call dtput (db, "\tbscale\t\t%g\n") + call pargr (rg_lstatr(ls, TBSCALE)) + call dtput (db, "\tbzero\t\t%g\n") + call pargr (rg_lstatr (ls, TBZERO)) + call dtput (db, "\tbserr\t\t%g\n") + call pargr (rg_lstatr (ls, TBSCALEERR)) + call dtput (db, "\tbzerr\t\t%g\n") + call pargr (rg_lstatr (ls, TBZEROERR)) +end + + +# RG_LPWREC -- Print the computed scaling factors for the region. + +procedure rg_lpwrec (ls, i) + +pointer ls #I pointer to the linmatch structure +int i #I the current region + +pointer rg_lstatp() +real rg_lstatr() + +begin + if (i == 0) { + call printf ( + "Results: bscale = %g +/- %g bzero = %g +/- %g\n") + call pargr (rg_lstatr (ls, TBSCALE)) + call pargr (rg_lstatr (ls, TBSCALEERR)) + call pargr (rg_lstatr (ls, TBZERO)) + call pargr (rg_lstatr (ls, TBZEROERR)) + } else { + call printf ( + "Region %d: [%d:%d,%d:%d] bscale = %g +/- %g bzero = %g +/- %g\n") + call pargi (i) + call pargi (Memi[rg_lstatp(ls,RC1)+i-1]) + call pargi (Memi[rg_lstatp(ls,RC2)+i-1]) + call pargi (Memi[rg_lstatp(ls,RL1)+i-1]) + call pargi (Memi[rg_lstatp(ls,RL2)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBSCALE)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBSCALEERR)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBZERO)+i-1]) + call pargr (Memr[rg_lstatp(ls,RBZEROERR)+i-1]) + } +end diff --git a/pkg/images/immatch/src/linmatch/rgldelete.x b/pkg/images/immatch/src/linmatch/rgldelete.x new file mode 100644 index 00000000..2e16923a --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgldelete.x @@ -0,0 +1,993 @@ +include +include +include "linmatch.h" + +# RG_LFIND -- Find the point nearest the cursor regardless of whether it +# has been deleted or not. + +int procedure rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, plot_type) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the wcs of the point +real wx #I the x coordinate of point to be deleted +real wy #I the y coordinate of point to be deleted +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type + +int region +int rg_mmffind(), rg_mmrfind(), rg_bzffind(), rg_bzrfind() +int rg_msffind(), rg_msrfind() + +begin + switch (plot_type) { + case LS_MMFIT: + region = rg_mmffind (gd, ls, wx, wy) + case LS_MMRESID: + region = rg_mmrfind (gd, ls, wx, wy, bscale, bzero) + case LS_BSZFIT: + region = rg_bzffind (gd, ls, wcs, wx, wy) + case LS_BSZRESID: + region = rg_bzrfind (gd, ls, wcs, wx, wy, bscale, bzero) + case LS_MAGSKYFIT: + region = rg_msffind (gd, ls, wcs, wx, wy) + case LS_MAGSKYRESID: + region = rg_msrfind (gd, ls, wcs, wx, wy, bscale, bzero) + default: + region = 0 + } + + return (region) +end + + +# RG_LDELETE -- Delete or undelete regions from the data. + +int procedure rg_ldelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, + plot_type, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs for multi-wcs plots +real wx #I the x coordinate of point to be deleted +real wy #I the y coordinate of point to be deleted +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type +int delete #I delete the point + +int region +int rg_rdelete(), rg_mmfdelete(), rg_mmrdelete(), rg_bzfdelete() +int rg_bzrdelete(), rg_msfdelete(), rg_msrdelete() + +begin + switch (plot_type) { + case LS_MMHIST: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_MMFIT: + region = rg_mmfdelete (gd, ls, udelete, wx, wy, delete) + case LS_MMRESID: + region = rg_mmrdelete (gd, ls, udelete, wx, wy, bscale, + bzero, delete) + case LS_RIFIT: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_RIRESID: + region = rg_rdelete (gd, ls, udelete, delete) + case LS_BSZFIT: + region = rg_bzfdelete (gd, ls, udelete, wcs, wx, wy, delete) + case LS_BSZRESID: + region = rg_bzrdelete (gd, ls, udelete, wcs, wx, wy, bscale, + bzero, delete) + case LS_MAGSKYFIT: + region = rg_msfdelete (gd, ls, udelete, wcs, wx, wy, delete) + case LS_MAGSKYRESID: + region = rg_msrdelete (gd, ls, udelete, wcs, wx, wy, bscale, + bzero, delete) + default: + region = 0 + } + + return (region) +end + + +# RG_RDELETE -- Delete or undelete a particular region from the data using +# a histogram or fit plot. + +int procedure rg_rdelete (gd, ls, udelete, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int delete #I delete the point + +int region +int rg_lstati() +pointer rg_lstatp() + +begin + # Get the current region. + region = rg_lstati (ls, CNREGION) + if (region < 1 || region > rg_lstati (ls, NREGIONS)) + return (0) + + # Delete or undelete the region. + if (delete == YES) { + if (Memi[rg_lstatp(ls,RDELETE)+region-1] == LS_NO) { + udelete[region] = YES + return (region) + } else + return (0) + } else { + if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) { + udelete[region] = NO + return (region) + } else + return (0) + } +end + + +# RG_MMFDELETE -- Delete or undelete a point computed from the mean, median, +# or mode. + +int procedure rg_mmfdelete (gd, ls, udelete, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int nregions, region, mtype +pointer sp, xdata, ydata +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + # Get the data. + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], nregions) + } + + # Delete or undelete the point. + if (delete == YES) + region = rg_lpdelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + else + region = rg_lpundelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + + call sfree (sp) + + return (region) +end + + +# RG_MMRDELETE -- Delete or undelete a point computed from the mean, median, +# or mode residuals plots. + +int procedure rg_mmrdelete (gd, ls, udelete, wx, wy, bscale, bzero, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the computed bscale factor +real bzero #I the computed bzero factor +int delete #I delete the input object + +int nregions, region, mtype +pointer sp, xdata, ydata +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], Memr[ydata], + nregions) + } + + # Delete or undelete the point. + if (delete == YES) + region = rg_lpdelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + else + region = rg_lpundelete (gd, 1, wx, wy, Memr[xdata], Memr[ydata], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + + call sfree (sp) + + return (region) +end + + +# RG_BZFDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_bzfdelete (gd, ls, udelete, wcs, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int i, nregions, region +pointer sp, xreg +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBSCALE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBZERO)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBSCALE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[rg_lstatp(ls,RBZERO)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } + + call sfree (sp) + + return (region) +end + + +# RG_BZRDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzero residuals. + +int procedure rg_bzrdelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, + delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value +int delete #I delete the input object + +int i, nregions, region +pointer sp, xreg, yreg +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], Memr[yreg], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else + region = 0 + } else { + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[xreg], + Memr[yreg], Memi[rg_lstatp(ls,RDELETE)], udelete, nregions) + } else + region = 0 + } + + call sfree (sp) + + return (region) +end + + +# RG_MSFDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_msfdelete (gd, ls, udelete, wcs, wx, wy, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +int delete #I delete the input object + +int nregions, region +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[rg_lstatp(ls,RMAG)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[rg_lstatp(ls,RSKY)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[rg_lstatp(ls,RMAG)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[rg_lstatp(ls,RSKY)], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions) + else + region = 0 + } + + return (region) +end + + +# RG_MSRDELETE -- Delete or undelete a point computed from the average +# of the fitted bscale or bzeros. + +int procedure rg_msrdelete (gd, ls, udelete, wcs, wx, wy, bscale, bzero, delete) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I/O the user deletions array +int wcs #I the wcs number +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value +int delete #I delete the input object + +int nregions, region +pointer sp, resid +int rg_lstati(), rg_lpdelete(), rg_lpundelete() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (resid, nregions, TY_REAL) + + if (wcs == 1) { + if (bscale > 0.0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[resid], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[resid], + Memr[resid], nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls, + IMAG)], Memr[resid], nregions) + } else { + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[resid], Memr[resid], + nregions) + } + + # Delete or undelete the point. + if (delete == YES) { + if (wcs == 1) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpdelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } else { + if (wcs == 1) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + IMAG)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else if (wcs == 2) + region = rg_lpundelete (gd, wcs, wx, wy, Memr[rg_lstatp(ls, + ISKY)], Memr[resid], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions) + else + region = 0 + } + + call sfree (sp) + + return (region) +end + +# RG_MMFFIND -- Find a point computed from the mean, median, or mode. + +int procedure rg_mmffind (gd, ls, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +real wx #I the input x coordinate +real wy #I the input y coordinate + +int nregions, mtype, region +pointer sp, xdata, ydata +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + # Get the data. + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call amovr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], nregions) + } + + region = rg_lpfind (gd, 1, wx, wy, Memr[xdata], Memr[ydata], nregions) + + call sfree (sp) + + return (region) +end + + +# RG_MMRFIND -- Find a point computed from the mean, median, or mode. + +int procedure rg_mmrfind (gd, ls, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale factor +real bzero #I the input bzero factor + +int nregions, mtype, region +pointer sp, xdata, ydata +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (0) + + # Allocate working space. + call smark (sp) + call salloc (xdata, nregions, TY_REAL) + call salloc (ydata, nregions, TY_REAL) + + switch (mtype) { + case LS_MEAN: + call amovr (Memr[rg_lstatp(ls,IMEAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MEDIAN: + call amovr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[ydata], Memr[ydata], + nregions) + case LS_MODE: + call amovr (Memr[rg_lstatp(ls,IMODE)], Memr[xdata], nregions) + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[ydata], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[ydata], Memr[ydata], + nregions) + } + + region = rg_lpfind (gd, 1, wx, wy, Memr[xdata], Memr[ydata], nregions) + + call sfree (sp) + + return (region) +end + + +# RG_BZFFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_bzffind (gd, ls, wcs, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate + +int i, nregions, region +pointer sp, xreg +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + + if (wcs == 1) + region = rg_lpfind (gd, 1, wx, wy, Memr[xreg], Memr[rg_lstatp(ls, + RBSCALE)], nregions) + else if (wcs == 2) + region = rg_lpfind (gd, 2, wx, wy, Memr[xreg], Memr[rg_lstatp(ls, + RBZERO)], nregions) + else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_BZRFIND -- Find a point computed from the bscale and bzero fit +# residuals to all the regions. + +int procedure rg_bzrfind (gd, ls, wcs, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bscale value + +int i, nregions, region +pointer sp, xreg, yreg +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + + do i = 1, nregions + Memr[xreg+i-1] = i + + if (wcs == 1) { + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], + nregions) + region = rg_lpfind (gd, 1, wx, wy, Memr[xreg], Memr[yreg], + nregions) + } else if (wcs == 2) { + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], + nregions) + region = rg_lpfind (gd, 2, wx, wy, Memr[xreg], Memr[yreg], + nregions) + } else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_MSFFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_msffind (gd, ls, wcs, wx, wy) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate + +int nregions, region +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + if (wcs == 1) + region = rg_lpfind (gd, 1, wx, wy, Memr[rg_lstatp(ls,IMAG)], + Memr[rg_lstatp(ls,RMAG)], nregions) + else if (wcs == 2) + region = rg_lpfind (gd, 2, wx, wy, Memr[rg_lstatp(ls,ISKY)], + Memr[rg_lstatp(ls,RSKY)], nregions) + else + region = 0 + + return (region) +end + + +# RG_MSRFIND -- Find a point computed from the bscale and bzero fits +# to all the regions. + +int procedure rg_msrfind (gd, ls, wcs, wx, wy, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int wcs #I the input wcs +real wx #I the input x coordinate +real wy #I the input y coordinate +real bscale #I the input bscale value +real bzero #I the input bzero value + +int nregions, region +pointer sp, resid +int rg_lstati(), rg_lpfind() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (0) + + call smark (sp) + call salloc (resid, nregions, TY_REAL) + + if (wcs == 1) { + if (bscale > 0.0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[resid], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[resid], Memr[resid], + nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls,IMAG)], + Memr[resid], nregions) + region = rg_lpfind (gd, 1, wx, wy, Memr[rg_lstatp(ls,IMAG)], + Memr[resid], nregions) + } else if (wcs == 2) { + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[resid], Memr[resid], + nregions) + region = rg_lpfind (gd, 2, wx, wy, Memr[rg_lstatp(ls,ISKY)], + Memr[resid], nregions) + } else + region = 0 + + call sfree (sp) + + return (region) +end + + +# RG_LPDELETE -- Delete a point from the plot. + +int procedure rg_lpdelete (gd, wcs, wx, wy, xdata, ydata, delete, udelete, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int delete[ARB] #I the deletions array +int udelete[ARB] #I/O the user deletions array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, r2, x0, y0 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + if (delete[i] != LS_NO) + next + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + if (region > 0) { + call gseti (gd, G_WCS, wcs) + call gscur (gd, xdata[region], ydata[region]) + call gmark (gd, xdata[region], ydata[region], GM_CROSS, 2.0, 2.0) + udelete[region] = YES + } + + return (region) +end + + +# RG_LPUNDELETE -- Undelete a point from the plot. + +int procedure rg_lpundelete (gd, wcs, wx, wy, xdata, ydata, delete, + udelete, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int delete[ARB] #I the deletions array +int udelete[ARB] #I/O the user deletions array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, r2, x0, y0 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + if (udelete[i] == NO) + next + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + if (region > 0) { + call gseti (gd, G_WCS, wcs) + call gscur (gd, xdata[region], ydata[region]) + call gseti (gd, G_PMLTYPE, GL_CLEAR) + call gmark (gd, xdata[region], ydata[region], GM_CROSS, 2.0, 2.0) + call gseti (gd, G_PMLTYPE, GL_SOLID) + call gmark (gd, xdata[region], ydata[region], GM_BOX, 2.0, 2.0) + udelete[region] = NO + } + + return (region) +end + + +# RG_LPFIND -- Find a point in the plot. + +int procedure rg_lpfind (gd, wcs, wx, wy, xdata, ydata, npts) + +pointer gd #I the graphics stream descriptor +int wcs #I the input wcs +real wx, wy #I the point to be deleted. +real xdata[ARB] #I the input x data array +real ydata[ARB] #I the input y data array +int npts #I the number of points + +int i, region +real wx0, wy0, r2min, x0, y0, r2 + +begin + call gctran (gd, wx, wy, wx0, wy0, wcs, 0) + r2min = MAX_REAL + region = 0 + + # Find the point to be deleted. + do i = 1, npts { + call gctran (gd, xdata[i], ydata[i], x0, y0, wcs, 0) + r2 = (x0 - wx0) ** 2 + (y0 - wy0) ** 2 + if (r2 < r2min) { + r2min = r2 + region = i + } + } + + return (region) +end + diff --git a/pkg/images/immatch/src/linmatch/rgliscale.x b/pkg/images/immatch/src/linmatch/rgliscale.x new file mode 100644 index 00000000..e760c7f8 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgliscale.x @@ -0,0 +1,593 @@ +include +include +include +include "linmatch.h" + +# Define the help files. +define HELPFILE "immatch$src/linmatch/linmatch.key" + +# RG_LISCALE -- Scale the output image interactively. + +int procedure rg_liscale (imr, im1, im2, db, dformat, reglist, rpfd, ipfd, sfd, + ls, gd, id) + +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the database file +int dformat #I is the scale file in database format +pointer reglist #I/O the regions list descriptor +int rpfd #I/O the reference photometry file descriptor +int ipfd #I/O the input photometry file descriptor +int sfd #I/O the shifts file descriptor +pointer ls #I pointer to the linmatch structure +pointer gd #I the graphics stream pointer +pointer id #I display stream pointer + +int i, newref, newimage, newfit, newavg, newplot, plottype, wcs, key, reg +int hplot, lplot, lplot_type +pointer sp, cmd, udelete, stat +real bscale, bzero, bserr, bzerr, wx, wy +int rg_lstati(), rg_lplot(), clgcur(), rg_lgqverify(), rg_lgtverify() +int rg_ldelete(), rg_lfind(), rg_mmhplot(), rg_rifplot(), rg_rirplot() +int rg_lregions() +pointer rg_lstatp() + +begin + call gdeactivate (gd, 0) + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (udelete, rg_lstati(ls, MAXNREGIONS), TY_INT) + + # Initialize the fitting. + newref = YES + newimage = YES + newfit = YES + newavg = YES + + # Initialize the plotting. + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_MMFIT + else + plottype = LS_MMHIST + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_BSZFIT + else + plottype = LS_RIFIT + case LS_PHOTOMETRY: + plottype = LS_BSZFIT + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_MMFIT + else + plottype = LS_MMHIST + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) + plottype = LS_BSZFIT + else + plottype = LS_RIFIT + case LS_PHOTOMETRY: + plottype = LS_BSZFIT + default: + } + + # Do the initial fit. + if (rg_lstati (ls, NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + bscale = 1.0; bzero = 0.0 + bserr = INDEFR; bzerr = INDEFR + call printf ("The regions/photometry list is empty\n") + } else { + call amovki (LS_NO, Memi[rg_lstatp(ls,RDELETE)], rg_lstati(ls, + NREGIONS)) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, bzerr, YES) + call amovki (NO, Memi[udelete], rg_lstati(ls,NREGIONS)) + if (rg_lplot (gd, imr, im1, ls, Memi[udelete], 1, bscale, bzero, + plottype) == OK) { + newref = NO + newimage = NO + newfit = NO + newavg = NO + call rg_lpwrec (ls, 0) + } else { + call gclear (gd) + call gflush (gd) + call rg_lstats (ls, IMAGE, Memc[cmd], SZ_FNAME) + call printf ("Error computing scale factors for image %s\n") + call pargstr (Memc[cmd]) + } + } + newplot = NO + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Quit the task gracefully. + case 'q': + if (rg_lgqverify ("linmatch", db, dformat, ls, + key) == YES) { + call sfree (sp) + return (rg_lgtverify (key)) + } + + # Refit the data. + case 'f': + if (newref == YES || newimage == YES || newfit == YES || + newavg == YES) { + if (rg_lstati(ls, BSALGORITHM) != LS_PHOTOMETRY && + rg_lstati(ls, BZALGORITHM) != LS_PHOTOMETRY) { + if (newref == YES) { + if (rg_lregions (reglist, imr, ls, 1, YES) > 0) + ; + } else if (newimage == YES) { + call rg_lindefr (ls) + } + } + if (newfit == YES) + call amovki (LS_NO, Memi[rg_lstatp(ls,RDELETE)], + rg_lstati(ls,NREGIONS)) + else if (newavg == YES) { + do i = 1, rg_lstati(ls,NREGIONS) { + if (Memi[rg_lstatp(ls,RDELETE)+i-1] == + LS_DELETED || Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_BADSIGMA) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_NO + } + + } + do i = 1, rg_lstati(ls,NREGIONS) { + if (Memi[udelete+i-1] == YES) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_DELETED + } + if (newfit == YES) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, + bzerr, YES) + else if (newavg == YES) + call rg_scale (imr, im1, ls, bscale, bzero, bserr, + bzerr, NO) + newref = NO + newimage = NO + newfit = NO + newavg = NO + newplot = YES + } + + # Plot the default graph. + case 'g': + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMFIT) + newplot = YES + plottype = LS_MMFIT + } else { + if (plottype != LS_MMHIST) + newplot = YES + plottype = LS_MMHIST + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + } else { + if (plottype != LS_RIFIT) + newplot = YES + plottype = LS_RIFIT + } + case LS_PHOTOMETRY: + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMFIT) + newplot = YES + plottype = LS_MMFIT + } else { + if (plottype != LS_MMHIST) + newplot = YES + plottype = LS_MMHIST + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZFIT) + plottype = LS_BSZFIT + } else { + if (plottype != LS_RIFIT) + plottype = LS_RIFIT + } + case LS_PHOTOMETRY: + if (plottype != LS_BSZFIT) + newplot = YES + plottype = LS_BSZFIT + default: + } + + # Graph the residuals from the current fit. + case 'i': + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMRESID) + newplot = YES + plottype = LS_MMRESID + } else { + call printf ( + "There are too few regions for a residuals plot\n") + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZRESID) + newplot = YES + plottype = LS_BSZRESID + } else { + if (plottype != LS_RIRESID) + newplot = YES + plottype = LS_RIRESID + } + case LS_PHOTOMETRY: + if (plottype == LS_BSZFIT) { + newplot = YES + plottype = LS_BSZRESID + } else if (plottype == LS_MAGSKYFIT) { + newplot = YES + plottype = LS_MAGSKYRESID + } + default: + } + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN, LS_MEDIAN, LS_MODE: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_MMRESID) + newplot = YES + plottype = LS_MMRESID + } else { + call printf ( + "There are too few regions for a residuals plot\n") + } + case LS_FIT: + if (rg_lstati (ls, NREGIONS) > 1) { + if (plottype != LS_BSZRESID) + newplot = YES + plottype = LS_BSZRESID + } else { + if (plottype != LS_RIRESID) + newplot = YES + plottype = LS_RIRESID + } + case LS_PHOTOMETRY: + if (plottype == LS_BSZFIT) { + newplot = YES + plottype = LS_BSZRESID + } else if (plottype == LS_MAGSKYFIT) { + newplot = YES + plottype = LS_MAGSKYRESID + } + default: + } + + # Plot the histogram and show the statistics of a given region. + # selected from a plot. + case 's': + if (imr != NULL && im1 != NULL) { + reg = rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, + plottype) + if (reg > 0) { + if (rg_mmhplot (gd, imr, im1, ls, Memi[udelete], + reg) == OK) { + call rg_lpwrec (ls, reg) + } else { + call printf ( + "Unable to plot statistics for region %d\n") + call pargi (reg) + } + } else + call printf ("Unable to plot region statistics\n") + } else + call printf ( + "The reference or input image is undefined\n") + + # Trace the fit of a given region selected from a plot. + case 't': + if (imr != NULL && im1 != NULL && (rg_lstati(ls, + BSALGORITHM) == LS_FIT || rg_lstati(ls,BZALGORITHM) == + LS_FIT)) { + reg = rg_lfind (gd, ls, wcs, wx, wy, bscale, bzero, + plottype) + if (reg > 0) { + if (plottype == LS_BSZFIT) + stat = rg_rifplot (gd, imr, im1, ls, + Memi[udelete], reg) + else if (plottype == LS_BSZRESID) + stat = rg_rirplot (gd, imr, im1, ls, + Memi[udelete], reg) + else + stat = ERR + if (stat == OK) + call rg_lpwrec (ls, reg) + else { + call printf ( + "Unable to plot statistics for region %d\n") + call pargi (reg) + } + } else + call printf ( + "Unable to plot region statistics\n") + } else + call printf ( + "The least squares fit is undefined\n") + + # Plot the statistics and show the histograms for each + # region in turn. + case 'h': + if (imr != NULL && im1 != NULL) { + reg = 1 + if (rg_mmhplot (gd, imr, im1, ls, Memi[udelete], + reg) == ERR) { + call printf ( + "Unable to plot statistics for region 1\n") + next + } + hplot = NO + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + switch (key) { + case '?': + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + case 'q': + call printf ("\n") + break + case ' ': + if (reg < rg_lstati (ls, NREGIONS)) { + reg = reg + 1 + hplot = YES + } + case '-': + if (reg > 1) { + reg = reg - 1 + hplot = YES + } + case 's': + call rg_lpwrec (ls, reg) + } + if (hplot == YES) { + if (rg_mmhplot (gd, imr, im1, ls, + Memi[udelete], reg) == ERR) + ; + call printf ( + "Hit [spbar=next,-=prev,s=stats,?=help,q=quit]:") + hplot = NO + } + } + newplot = YES + } else + call printf ( + "The reference or input image is undefined\n") + + # Step through the least sqares fits one at a time. + case 'l': + if (imr != NULL && im1 != NULL && (rg_lstati(ls, + BSALGORITHM) == LS_FIT || rg_lstati(ls,BZALGORITHM) == + LS_FIT)) { + reg = 1 + lplot = NO + if (plottype == LS_BSZFIT || plottype == LS_RIFIT) + lplot_type = LS_RIFIT + else if (plottype == LS_BSZRESID || plottype == + LS_RIRESID) + lplot_type = LS_RIRESID + if (lplot_type == LS_RIFIT) + stat = rg_rifplot (gd, imr, im1, ls, Memi[udelete], + reg) + else if (lplot_type == LS_RIRESID) + stat = rg_rirplot (gd, imr, im1, ls, Memi[udelete], + reg) + else + stat = ERR + if (stat == ERR) { + call printf ("Unable to plot fits for region 1\n") + next + } + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + switch (key) { + case '?': + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + case 'q': + call printf ("\n") + break + case ' ': + if (reg < rg_lstati (ls, NREGIONS)) { + reg = reg + 1 + lplot = YES + } + case '-': + if (reg > 1) { + reg = reg - 1 + lplot = YES + } + case 'l': + if (lplot_type == LS_RIRESID) + lplot = YES + lplot_type = LS_RIFIT + case 'i': + if (lplot_type == LS_RIFIT) + lplot = YES + lplot_type = LS_RIRESID + case 's': + call rg_lpwrec (ls, reg) + } + if (lplot == YES) { + if (lplot_type == LS_RIFIT) + stat = rg_rifplot (gd, imr, im1, ls, + Memi[udelete], reg) + else if (lplot_type == LS_RIRESID) + stat = rg_rirplot (gd, imr, im1, ls, + Memi[udelete], reg) + call printf ( + "Hit [spbar=next,-=prev,l=fit,i=resid,s=stats,?=help,q=quit]:") + lplot = NO + } + } + newplot = YES + } else + call printf ( + "The least squares fit is undefined\n") + + # Plot the photometry + case 'p': + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) { + plottype = LS_MAGSKYFIT + newplot = YES + } else + call printf ("The input photometry is undefined\n") + + # Replot the current graph. + case 'r': + newplot = YES + + # Delete or undelete a region. + case 'd', 'u': + if (key == 'd') + reg = rg_ldelete (gd, ls, Memi[udelete], wcs, wx, wy, + bscale, bzero, plottype, YES) + else + reg = rg_ldelete (gd, ls, Memi[udelete], wcs, wx, wy, + bscale, bzero, plottype, NO) + if (reg > 0) + newavg = YES + + + # Process colon commands. + case ':': + call rg_lcolon (gd, ls, imr, im1, im2, db, dformat, + reglist, rpfd, ipfd, sfd, Memc[cmd], newref, + newimage, newfit, newavg) + + # Write the parameters to the parameter file. + case 'w': + call rg_plpars (ls) + + # Do nothing gracefully. + default: + } + + if (newplot == YES) { + if (rg_lstati(ls,NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + bscale = 1.0; bzero = 0.0 + bserr = INDEFR; bzerr = INDEFR + call printf ("The regions/photometry list is empty\n") + } else if (newref == YES || newimage == YES) { + call printf ("Bscale and bzero must be recomputed\n") + } else if (rg_lplot (gd, imr, im1, ls, Memi[udelete], 1, + bscale, bzero, plottype) == OK) { + if (newfit == YES || newavg == YES) + call printf ("Bscale and bzero should be recomputed\n") + else + call rg_lpwrec (ls, 0) + newplot = NO + } else + call printf ("Unable to plot image data for region 1\n") + } + + } + + call sfree (sp) +end + +define QUERY "Hit [return=continue, n=next image, q=quit, w=quit and update parameters]: " + +# RG_LGQVERIFY -- Print a message on the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_lgqverify (task, db, dformat, rg, ch) + +char task[ARB] #I the calling task name +pointer db #I pointer to the shifts database file +int dformat #I is the shifts file in database format +pointer rg #I pointer to the task structure +int ch #I the input keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + #call flush (STDOUT) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + call rg_lwrec (db, dformat, rg) + stat = YES + } else if (ch == 'w') { + call rg_lwrec (db, dformat, rg) + if (streq ("linmatch", task)) + call rg_plpars (rg) + stat = YES + } else if (ch == 'n') { + call rg_lwrec (db, dformat, rg) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + return (stat) +end + + +# RG_LGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_lgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end diff --git a/pkg/images/immatch/src/linmatch/rglpars.x b/pkg/images/immatch/src/linmatch/rglpars.x new file mode 100644 index 00000000..d5f66320 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglpars.x @@ -0,0 +1,104 @@ +include +include "linmatch.h" + + +# RG_GLPARS -- Fetch the algorithm parameters required by the intensity scaling +# task. + +procedure rg_glpars (ls) + +pointer ls #I pointer to iscale structure + +int ip, nchars +pointer sp, str1, str2 +int clgeti(), nscan(), lexnum() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Initialize the linscale structure. + call rg_linit (ls, clgeti ("maxnregions")) + + # Get the x and y shifts. + call rg_lsetr (ls, XSHIFT, clgetr("xshift")) + call rg_lsetr (ls, YSHIFT, clgetr("yshift")) + + # Get the scaling algorithm parameters. + call clgstr ("scaling", Memc[str1], SZ_LINE) + call sscan (Memc[str1]) + call gargwrd (Memc[str1], SZ_LINE) + call gargwrd (Memc[str2], SZ_LINE) + call rg_lsets (ls, BSSTRING, Memc[str1]) + ip = 1 + if (nscan() == 2) + call rg_lsets (ls, BZSTRING, Memc[str2]) + else if (lexnum(Memc[str1], ip, nchars) == LEX_NONNUM) + call rg_lsets (ls, BZSTRING, Memc[str1]) + else + call rg_lsets (ls, BZSTRING, "0.0") + + call rg_lseti (ls, DNX, clgeti ("dnx")) + call rg_lseti (ls, DNY, clgeti ("dny")) + call rg_lseti (ls, MAXITER, clgeti ("maxiter")) + call rg_lsetr (ls, DATAMIN, clgetr ("datamin")) + call rg_lsetr (ls, DATAMAX, clgetr ("datamax")) + call rg_lseti (ls, NREJECT, clgeti ("nreject")) + call rg_lsetr (ls, LOREJECT, clgetr ("loreject")) + call rg_lsetr (ls, HIREJECT, clgetr ("hireject")) + + call clgstr ("gain", Memc[str1], SZ_LINE) + call rg_lsets (ls, CCDGAIN, Memc[str1]) + call clgstr ("readnoise", Memc[str1], SZ_LINE) + call rg_lsets (ls, CCDREAD, Memc[str1]) + + call sfree (sp) +end + + +# RG_PLPARS -- Save the intensity scaling parameters in the .par file. + +procedure rg_plpars (ls) + +pointer ls # pointer to the linscale structure + +pointer sp, str1, str2, str +int rg_lstati() +real rg_lstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Set the x and y shifts parameters. + call clputr ("xshift", rg_lstatr (ls, XSHIFT)) + call clputr ("yshift", rg_lstatr (ls, YSHIFT)) + + # Scaling algorithm parameters. + call rg_lstats (ls, BSSTRING, Memc[str1], SZ_LINE) + call rg_lstats (ls, BZSTRING, Memc[str2], SZ_LINE) + call sprintf (Memc[str], SZ_FNAME, "%s %s") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call clpstr ("scaling", Memc[str]) + call clputi ("dnx", rg_lstati (ls, DNX)) + call clputi ("dny", rg_lstati (ls, DNY)) + call clputi ("maxiter", rg_lstati (ls, MAXITER)) + call clputr ("datamin", rg_lstatr (ls, DATAMIN)) + call clputr ("datamax", rg_lstatr (ls, DATAMAX)) + call clputi ("nreject", rg_lstati (ls, NREJECT)) + call clputr ("loreject", rg_lstatr (ls, LOREJECT)) + call clputr ("hireject", rg_lstatr (ls, HIREJECT)) + call rg_lstats (ls, CCDGAIN, Memc[str], SZ_FNAME) + call clpstr ("gain", Memc[str]) + call rg_lstats (ls, CCDREAD, Memc[str], SZ_FNAME) + call clpstr ("readnoise", Memc[str]) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rglplot.x b/pkg/images/immatch/src/linmatch/rglplot.x new file mode 100644 index 00000000..e46f3bcd --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglplot.x @@ -0,0 +1,1592 @@ +include +include +include "linmatch.h" + +define MINFRACTION 0.01 +define FRACTION 0.05 + +# XP_LPLOT -- Plot the data. + +int procedure rg_lplot (gd, imr, im1, ls, udelete, region, bscale, bzero, + plot_type) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +int region #I the current region if applicable +real bscale #I the computed bscale value +real bzero #I the computed bzero value +int plot_type #I the current plot type + +int stat +int rg_mmhplot(), rg_mmfplot(), rg_mmrplot(), rg_rifplot(), rg_rirplot() +int rg_bzfplot(), rg_bzrplot(), rg_msfplot(), rg_msrplot() + +begin + stat = OK + + switch (plot_type) { + case LS_MMHIST: + stat = rg_mmhplot (gd, imr, im1, ls, udelete, region) + case LS_MMFIT: + stat = rg_mmfplot (gd, ls, udelete, bscale, bzero) + case LS_MMRESID: + stat = rg_mmrplot (gd, ls, udelete, bscale, bzero) + case LS_RIFIT: + stat = rg_rifplot (gd, imr, im1, ls, udelete, region) + case LS_RIRESID: + stat = rg_rirplot (gd, imr, imr, ls, udelete, region) + case LS_BSZFIT: + stat = rg_bzfplot (gd, ls, udelete, bscale, bzero) + case LS_BSZRESID: + stat = rg_bzrplot (gd, ls, udelete, bscale, bzero) + case LS_MAGSKYFIT: + stat = rg_msfplot (gd, ls, udelete, bscale, bzero) + case LS_MAGSKYRESID: + stat = rg_msrplot (gd, ls, udelete, bscale, bzero) + default: + stat = ERR + } + + return (stat) +end + + +# RG_MMHPLOT -- Plot the histogram of the data used to compute the mean, median,# and mode. + +int procedure rg_mmhplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deleteions array +int region #I the current region if applicable + +int nbinsr, nbins1 +pointer rbuf, ibuf, sp, hgmi, hgmr, image, title, str +real rsigma, hminr, hmaxr, dhr, isigma, hmin1, hmax1, dh1, ymin, ymax +int rg_lstati(), rg_limget() +pointer rg_lstatp() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Get the reference image binning parameters. + rsigma = sqrt (real(Memi[rg_lstatp(ls,RNPTS)+region-1])) * + Memr[rg_lstatp(ls,RSIGMA)+region-1] + hminr = Memr[rg_lstatp(ls,RMEDIAN)+region-1] - LMODE_HWIDTH * rsigma + hmaxr = Memr[rg_lstatp(ls,RMEDIAN)+region-1] + LMODE_HWIDTH * rsigma + dhr = LMODE_ZBIN * rsigma + if (dhr <= 0.0) + return (ERR) + nbinsr = (hmaxr - hminr) / dhr + 1 + if (nbinsr <= 0) + return (ERR) + + # Get the input image binning parameters. + isigma = sqrt (real(Memi[rg_lstatp(ls,INPTS)+region-1])) * + Memr[rg_lstatp(ls,ISIGMA)+region-1] + hmin1 = Memr[rg_lstatp(ls,IMEDIAN)+region-1] - LMODE_HWIDTH * isigma + hmax1 = Memr[rg_lstatp(ls,IMEDIAN)+region-1] + LMODE_HWIDTH * isigma + dh1 = LMODE_ZBIN * isigma + if (dh1 <= 0.0) + return (ERR) + nbins1 = (hmax1 - hmin1) / dh1 + 1 + if (nbins1 <= 0.0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (hgmi, max (nbinsr, nbins1), TY_INT) + call salloc (hgmr, max (nbinsr, nbins1), TY_REAL) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + call gclear (gd) + + # Create the reference histogram. + call aclri (Memi[hgmi], nbinsr) + call ahgmr (Memr[rbuf], Memi[rg_lstatp(ls,RNPTS)+region-1], + Memi[hgmi], nbinsr, hminr, hmaxr) + call achtir (Memi[hgmi], Memr[hgmr], nbinsr) + call alimr (Memr[hgmr], nbinsr, ymin, ymax) + + # Compute the limits for the reference histogram. + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.1, 0.9, 0.6, 0.9) + call gswind (gd, hminr, hmaxr, ymin, ymax) + call rg_pfill (gd, hminr, hmaxr, ymin, ymax, GF_SOLID, 0) + call rg_lstats (ls, REFIMAGE, Memc[image], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Mean = %g Median = %g Mode = %g Sigma = %g") + call pargr (Memr[rg_lstatp(ls,RMEAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,RMEDIAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,RMODE)+region-1]) + call pargr (rsigma) + + # Create the title for the reference histogram. + call sprintf (Memc[title], 2 * SZ_LINE, + "Ref Image: %s Region: %d%s\nNbins = %d Hmin = %g Hmax = %g Dh = %g\n%s\n") + call pargstr (Memc[image]) + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargi (nbinsr) + call pargr (hminr) + call pargr (hmaxr) + call pargr (dhr) + call pargstr (Memc[str]) + call gseti (gd, G_YNMINOR, 0) + call glabax (gd, Memc[title], "", "") + + # Plot the reference histogram. + call rg_lhbox (gd, Memr[hgmr], nbinsr, hminr - dhr / 2.0, + hmaxr + dhr / 2.0) + + # Create the input histogram. + call aclri (Memi[hgmi], nbins1) + call ahgmr (Memr[ibuf], Memi[rg_lstatp(ls,INPTS)+region-1], + Memi[hgmi], nbins1, hmin1, hmax1) + call achtir (Memi[hgmi], Memr[hgmr], nbins1) + call alimr (Memr[hgmr], nbins1, ymin, ymax) + + # Compute the limits for the input histogram. + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.1, 0.9, 0.1, 0.4) + call gswind (gd, hmin1, hmax1, ymin, ymax) + call rg_pfill (gd, hmin1, hmax1, ymin, ymax, GF_SOLID, 0) + + # Create the title for the input histogram. + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Mean = %g Median = %g Mode = %g Sigma = %g") + call pargr (Memr[rg_lstatp(ls,IMEAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,IMEDIAN)+region-1]) + call pargr (Memr[rg_lstatp(ls,IMODE)+region-1]) + call pargr (isigma) + call sprintf (Memc[title], 2 * SZ_LINE, + "Input Image: %s Region: %d%s\nNbins = %d Hmin = %g Hmax = %g Dh = %g\n%s\n") + call pargstr (Memc[image]) + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargi (nbins1) + call pargr (hmin1) + call pargr (hmax1) + call pargr (dh1) + call pargstr (Memc[str]) + call gseti (gd, G_YNMINOR, 0) + call glabax (gd, Memc[title], "", "") + + # Plot the input histogram. + call rg_lhbox (gd, Memr[hgmr], nbins1, hmin1 - dh1 / 2.0, + hmax1 + dh1 / 2.0) + + call sfree (sp) + + return (OK) +end + + +# RG_MMFPLOT -- Plot the fit computed from the mean, median, or mode. + +int procedure rg_mmfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +bool start, finish +int nregions, mtype +pointer sp, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_LINE, TY_CHAR) + + # Clear the plot space. + call gclear (gd) + + # Compute the limits of the plot. + switch (mtype) { + case LS_MEAN: + call rg_galimr (Memr[rg_lstatp(ls,IMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + case LS_MEDIAN: + call rg_galimr (Memr[rg_lstatp(ls,IMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + case LS_MODE: + call rg_galimr (Memr[rg_lstatp(ls,IMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[rg_lstatp(ls,RMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, ymin, ymax) + } + dxmin = xmin + dxmax = xmax + dymin = ymin + dymax = ymax + + diff = xmax - xmin + if (diff <= 0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Construct the titles and axis labels. + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Nregions = %d Ref Image = %g * Input Image + %g") + call pargi (nregions) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Counts for %s versus Counts for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref Image Counts") + + # Plot the data. + switch (mtype) { + case LS_MEAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEAN)], + Memr[rg_lstatp(ls,RMEAN)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + case LS_MEDIAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEDIAN)], + Memr[rg_lstatp(ls,RMEDIAN)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + case LS_MODE: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMODE)], + Memr[rg_lstatp(ls,RMODE)], Memi[rg_lstatp(ls,RDELETE)], + udelete, nregions, GM_BOX, GM_CROSS) + } + + # Plot the fit. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_MMRPLOT -- Plot the residuals from the fit computed from the mean, +# median, or mode. + +int procedure rg_mmrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int nregions, mtype +pointer sp, resid, title, imager, image1, str +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Determine the type of data to plot. + mtype = 0 + switch (rg_lstati(ls, BSALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + switch (rg_lstati(ls, BZALGORITHM)) { + case LS_MEAN: + mtype = LS_MEAN + case LS_MEDIAN: + mtype = LS_MEDIAN + case LS_MODE: + mtype = LS_MODE + default: + } + if (mtype <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + + call gclear (gd) + + # Compute the data. + call salloc (resid, nregions, TY_REAL) + switch (mtype) { + case LS_MEAN: + call altmr (Memr[rg_lstatp(ls,IMEAN)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEAN)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMEAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + case LS_MEDIAN: + call altmr (Memr[rg_lstatp(ls,IMEDIAN)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMEDIAN)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMEDIAN)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + case LS_MODE: + call altmr (Memr[rg_lstatp(ls,IMODE)], Memr[resid], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RMODE)], Memr[resid], Memr[resid], + nregions) + call rg_galimr (Memr[rg_lstatp(ls,IMODE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, xmin, xmax) + call rg_galimr (Memr[resid], Memi[rg_lstatp(ls,RDELETE)], nregions, + ymin, ymax) + } + + # Compute the data limits. + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Nregions = %d Ref Image = %g * Input Image + %g") + call pargi (nregions) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s versus Counts for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Residual Counts") + + # Plot the data. + switch (mtype) { + case LS_MEAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEAN)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + case LS_MEDIAN: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMEDIAN)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + case LS_MODE: + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMODE)], Memr[resid], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, + GM_BOX, GM_CROSS) + } + + # Plot the residuals 0 line. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_RIFPLOT -- Plot the pixel to pixel fit for a region. + +int procedure rg_rifplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I pointer to the user deletions array +int region #I the current region + +bool start, finish +int npts +pointer rbuf, ibuf, sp, title, str, imager, image1, resid +real xmin, xmax, ymin, ymax, diff, bscale, bzero, datamin, datamax +real loreject, hireject, chi, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati(), rg_limget() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Initialize. + call gclear (gd) + + # Get some constants + npts = Memi[rg_lstatp(ls,RNPTS)+region-1] + bscale = Memr[rg_lstatp(ls,RBSCALE)+region-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+region-1] + chi = Memr[rg_lstatp(ls,RCHI)+region-1] + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls,DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls,DATAMAX) + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + IS_INDEFR(chi)) + loreject = -MAX_REAL + else + loreject = -rg_lstatr (ls,LOREJECT) * chi + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,HIREJECT)) || + IS_INDEFR(chi)) + hireject = MAX_REAL + else + hireject = rg_lstatr (ls,HIREJECT) * chi + + # Compute the plot limits. + call alimr (Memr[ibuf], npts, xmin, xmax) + call alimr (Memr[rbuf], npts, ymin, ymax) + dxmin = xmin + dxmax = xmax + dymin = ymin + dymax = ymax + + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmax + xmin) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymax + ymin) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Allocate working space. + call smark (sp) + + # Create the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Region %d%s: Ref Image = %g * Input Image + %g") + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Counts for Image %s versus Counts for Image %s\n%s\n\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref image Counts") + + # Compute the residuals. + call salloc (resid, npts, TY_REAL) + if (IS_INDEFR(bscale) || IS_INDEFR(bzero)) + call amovkr (0.0, Memr[resid], npts) + else { + call altmr (Memr[ibuf], Memr[resid], npts, bscale, bzero) + call asubr (Memr[rbuf], Memr[resid], Memr[resid], npts) + } + + # Plot the data. + call rg_riplot (gd, Memr[ibuf], Memr[rbuf], Memr[resid], npts, + datamin, datamax, loreject, hireject, GM_BOX, GM_CROSS) + + # Plot the fit if bscale and bzero are defined. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_RIRPLOT -- Plot the pixel to pixel fit residuals for a region. + +int procedure rg_rirplot (gd, imr, im1, ls, udelete, region) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I pointer to the user deletions array +int region #I the current region + +int npts +pointer rbuf, ibuf, sp, title, str, imager, image1, resid +real xmin, xmax, ymin, ymax, diff, bscale, bzero, datamin, datamax +real loreject, hireject, chi +int rg_lstati(), rg_limget() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data. + if (imr == NULL || im1 == NULL) { + return (ERR) + } else if (region == rg_lstati (ls,CNREGION) && + rg_lstatp (ls,RBUF) != NULL && rg_lstatp(ls, IBUF) != NULL) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else if (rg_limget (ls, imr, im1, region) == OK) { + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + } else { + return (ERR) + } + + # Initialize. + call gclear (gd) + + # Get some constants + npts = Memi[rg_lstatp(ls,RNPTS)+region-1] + bscale = Memr[rg_lstatp(ls,RBSCALE)+region-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+region-1] + chi = Memr[rg_lstatp(ls,RCHI)+region-1] + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls,DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls,DATAMAX) + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + IS_INDEFR(chi)) + loreject = -MAX_REAL + else + loreject = -rg_lstatr (ls,LOREJECT) * chi + if (rg_lstati(ls,NREJECT) <= 0 || IS_INDEFR(rg_lstatr(ls,HIREJECT)) || + IS_INDEFR(chi)) + hireject = MAX_REAL + else + hireject = rg_lstatr (ls,HIREJECT) * chi + + # Allocate working space. + call smark (sp) + + # Compute the residuals. + call salloc (resid, npts, TY_REAL) + if (IS_INDEFR(bscale) || IS_INDEFR(bzero)) + call amovkr (INDEFR, Memr[resid], npts) + else { + call altmr (Memr[ibuf], Memr[resid], npts, bscale, bzero) + call asubr (Memr[rbuf], Memr[resid], Memr[resid], npts) + } + + # Compute the plot limits. + call alimr (Memr[ibuf], npts, xmin, xmax) + call alimr (Memr[resid], npts, ymin, ymax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (xmin + xmax) / 2.0) + xmin = xmin - diff * FRACTION + xmax = xmax + diff * FRACTION + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymin + ymax) / 2.0) + ymin = ymin - diff * FRACTION + ymax = ymax + diff * FRACTION + call gswind (gd, xmin, xmax, ymin, ymax) + + # Create the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + + # Create the plot title. + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Region %d%s: Ref Image = %g * Input Image + %g") + call pargi (region) + if (udelete[region] == YES) + call pargstr (" [deleted]") + else if (Memi[rg_lstatp(ls,RDELETE)+region-1] != LS_NO) + call pargstr (" [rejected]") + else + call pargstr ("") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for Image %s versus Counts for Image %s\n%s\n\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Image Counts", + "Ref image Counts") + + # Plot the data. + call rg_rriplot (gd, Memr[ibuf], Memr[rbuf], Memr[resid], npts, + datamin, datamax, loreject, hireject, GM_BOX, GM_CROSS) + + # Plot the 0 line if bscale and bzero are defined. + if ( ! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + } + + call sfree (sp) + + return (OK) +end + + +# RG_BZFPLOT -- Plot the bscale and bzero values computed from the +# fit algorithm. + +int procedure rg_bzfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int i, nregions +pointer sp, xreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Allocate working space. + call smark (sp) + + # Set up space and info the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + else + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + + # Set the x array. + call salloc (xreg, nregions, TY_REAL) + do i = 1, nregions + Memr[xreg+i-1] = i + xmin = 1.0 - FRACTION * (nregions - 1) + xmax = nregions + FRACTION * (nregions - 1) + + call gclear (gd) + + # Determine the limits of bscale versus region. + call alimr (Memr[rg_lstatp(ls,RBSCALE)], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bscale vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bscale") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[rg_lstatp(ls,RBSCALE)], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, bscale) + call gadraw (gd, xmax, bscale) + + # Determine the limits of bzero versus region. + call alimr (Memr[rg_lstatp(ls,RBZERO)], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * abs (ymin + ymax) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bzero versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, "Bzero vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bzero") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[rg_lstatp(ls,RBZERO)], + Memi[rg_lstatp(ls,RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, bzero) + call gadraw (gd, xmax, bzero) + + call sfree (sp) + + return (OK) +end + + +# RG_BZRPLOT -- Plot the bscale and bzero values computed from the +# fit algorithm. + +int procedure rg_bzrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int i, nregions +pointer sp, xreg, yreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 1) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (xreg, nregions, TY_REAL) + call salloc (yreg, nregions, TY_REAL) + + # Set up space and info the plot title. + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + else + call rg_lstats (ls, IMAGE, Memc[image1], SZ_FNAME) + + # Set the x array. + do i = 1, nregions + Memr[xreg+i-1] = i + xmin = 1.0 - FRACTION * (nregions - 1) + xmax = nregions + FRACTION * (nregions - 1) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call asubkr (Memr[rg_lstatp(ls,RBSCALE)], bscale, Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bscale Residuals vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bscale Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[yreg], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + # Determine the limits of the bscale value versus region. + call asubkr (Memr[rg_lstatp(ls,RBZERO)], bzero, Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bzero versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Bzero Residuals vs. Region\n%s\n") + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Region", "Bzero Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[xreg], Memr[yreg], Memi[rg_lstatp(ls, + RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_MSFPLOT -- Plot the magnitude and sky values of the regions. + +int procedure rg_msfplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +bool start, finish +int nregions +pointer sp, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dxmin, dxmax, dymin, dymax, x, y +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,IMAG)], nregions, xmin, xmax) + dxmin = xmin + dxmax = xmax + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call alimr (Memr[rg_lstatp(ls,RMAG)], nregions, ymin, ymax) + dymin = ymin + dymax = ymax + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference magnitudes = Input magnitudes + %0.3f") + call pargr (-2.5 * log10 (bscale)) + call sprintf (Memc[title], 2 * SZ_LINE, + "Magnitudes for %s vs. Magnitudes for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Magnitudes", + "Ref Magnitudes") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMAG)], Memr[rg_lstatp(ls,RMAG)], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + if (bscale > 0.0) { + call gamove (gd, dxmin, dxmin - 2.5 * log10(bscale)) + call gadraw (gd, dxmax, dxmax - 2.5 * log10(bscale)) + } + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,ISKY)], nregions, xmin, xmax) + dxmin = xmin + dxmax = xmax + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call alimr (Memr[rg_lstatp(ls,RSKY)], nregions, ymin, ymax) + dymin = ymin + dymax = ymax + diff = ymax - ymin + if (diff <= 0.0) + diff = 0.0 + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference skies = %g * Input skies + %g") + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Sky Values for %s vs. Sky Values for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Sky Values", + "Ref Sky Values") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,ISKY)], Memr[rg_lstatp(ls,RSKY)], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + start = false + finish = false + if (! IS_INDEFR(bscale) && ! IS_INDEFR(bzero)) { + y = bscale * dxmin + bzero + if (y >= ymin && y <= ymax) { + call gamove (gd, dxmin, y) + start = true + } + y = bscale * dxmax + bzero + if (y >= ymin && y <= ymax) { + if (start) { + call gadraw (gd, dxmax, y) + finish = true + } else { + call gamove (gd, dxmax, y) + start = true + } + } + x = (dymin - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymin) + start = true + } else if (! finish) { + call gadraw (gd, x, dymin) + finish = true + } + } + x = (dymax - bzero) / bscale + if (x >= xmin && x <= xmax) { + if (! start) { + call gamove (gd, x, dymax) + start = true + } else if (! finish) { + call gadraw (gd, x, dymax) + finish = true + } + } + } + + call sfree (sp) + + return (OK) +end + + +# RG_MSRPLOT -- Plot the magnitude and sky values of the regions. + +int procedure rg_msrplot (gd, ls, udelete, bscale, bzero) + +pointer gd #I pointer to the graphics stream +pointer ls #I pointer to the linmatch structure +int udelete[ARB] #I the user deletions array +real bscale #I the fitted bscale value +real bzero #I the fitted bzero value + +int nregions +pointer sp, yreg, title, str, imager, image1 +real xmin, xmax, ymin, ymax, diff, dmin, dmax +int rg_lstati() +pointer rg_lstatp() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions <= 0) + return (ERR) + + # Allocate working space. + call smark (sp) + call salloc (yreg, nregions, TY_REAL) + call salloc (title, 2 * SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, REFIMAGE, Memc[imager], SZ_FNAME) + call rg_lstats (ls, PHOTFILE, Memc[image1], SZ_FNAME) + + call gclear (gd) + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,IMAG)], nregions, xmin, xmax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + dmin = xmin + dmax = xmax + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + if (bscale > 0) { + call aaddkr (Memr[rg_lstatp(ls,IMAG)], -2.5*log10(bscale), + Memr[yreg], nregions) + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[yreg], Memr[yreg], + nregions) + } else + call asubr (Memr[rg_lstatp(ls,RMAG)], Memr[rg_lstatp(ls,IMAG)], + Memr[yreg], nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 1) + call gsview (gd, 0.15, 0.9, 0.6, 0.9) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s vs. Magnitudes for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Magnitudes", + "Mag Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,IMAG)], Memr[yreg], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + if (bscale > 0.0) { + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + } + + # Determine the limits of the bscale value versus region. + call alimr (Memr[rg_lstatp(ls,ISKY)], nregions, xmin, xmax) + diff = xmax - xmin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (xmax + xmin) / 2.0) + dmin = xmin + dmax = xmax + xmin = xmin - FRACTION * diff + xmax = xmax + FRACTION * diff + call altmr (Memr[rg_lstatp(ls,ISKY)], Memr[yreg], nregions, + bscale, bzero) + call asubr (Memr[rg_lstatp(ls,RSKY)], Memr[yreg], Memr[yreg], + nregions) + call alimr (Memr[yreg], nregions, ymin, ymax) + diff = ymax - ymin + if (diff <= 0.0) + diff = MINFRACTION + else + diff = max (diff, MINFRACTION * (ymax + ymin) / 2.0) + ymin = ymin - FRACTION * diff + ymax = ymax + FRACTION * diff + call gseti (gd, G_WCS, 2) + call gsview (gd, 0.15, 0.9, 0.1, 0.4) + call gswind (gd, xmin, xmax, ymin, ymax) + call rg_pfill (gd, xmin, xmax, ymin, ymax, GF_SOLID, 0) + + # Create the title for bscale versus region. + call sprintf (Memc[str], SZ_LINE, + "Reference: %s Input: %s Bscale: %g Bzero: %g") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargr (bscale) + call pargr (bzero) + call sprintf (Memc[title], 2 * SZ_LINE, + "Residuals for %s vs. Sky Values for %s\n%s\n") + call pargstr (Memc[imager]) + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call glabax (gd, Memc[title], "Input Sky Values", + "Sky Residuals") + + # Plot the points. + call rg_lxyplot (gd, Memr[rg_lstatp(ls,ISKY)], Memr[yreg], + Memi[rg_lstatp(ls, RDELETE)], udelete, nregions, GM_BOX, GM_CROSS) + + # Plot the fit. + call gamove (gd, xmin, 0.0) + call gadraw (gd, xmax, 0.0) + + call sfree (sp) + + return (OK) +end + + +# RG_LHBOX -- Draw a stepped curve of the histogram data. + +procedure rg_lhbox (gp, ydata, npts, x1, x2) + +pointer gp #I the graphics descriptor +real ydata[ARB] #I the y coordinates of the line endpoints +int npts #I the number of line endpoints +real x1, x2 #I starting and ending x coordinates + +int pixel +real left, right, top, bottom, x, y, dx + +begin + call ggwind (gp, left, right, bottom, top) + dx = (x2 - x1) / npts + + # Do the first vertical line. + call gamove (gp, x1, bottom) + call gadraw (gp, x1, ydata[1]) + + # Do the first horizontal line. + call gadraw (gp, x1 + dx, ydata[1]) + + # Draw the remaining horizontal lines. + do pixel = 2, npts { + x = x1 + dx * (pixel - 1) + y = ydata[pixel] + call gadraw (gp, x, y) + call gadraw (gp, x + dx, y) + } + + # Draw the last vertical line. + call gadraw (gp, x + dx, bottom) +end + + +# RG_PFILL -- Fill a rectangular area with a given style and color. + +procedure rg_pfill (gd, xmin, xmax, ymin, ymax, fstyle, fcolor) + +pointer gd #I pointer to the graphics stream +real xmin, xmax #I the x coordinate limits +real ymin, ymax #I the y coordinate limits +int fstyle #I the fill style +int fcolor #I the fill color + +real x[4], y[4] + +begin + call gseti (gd, G_FACOLOR, fcolor) + x[1] = xmin; y[1] = ymin + x[2] = xmax; y[2] = ymin + x[3] = xmax; y[3] = ymax + x[4] = xmin; y[4] = ymax + call gfill (gd, x, y, 4, fstyle) +end + + +# XP_LXYPLOT -- Plot the x and y points. + +procedure rg_lxyplot (gd, x, y, del, udel, npts, gmarker, dmarker) + +pointer gd # pointer to the graphics stream +real x[ARB] # the x coordinates +real y[ARB] # the y coordinates +int del[ARB] # the deletions array +int udel[ARB] # the user deletions array +int npts # the number of points to be marked +int gmarker # the good point marker type +int dmarker # the deleted point marker type + +int i + +begin + # Plot the points. + do i = 1, npts { + if (udel[i] == YES) { + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + } else if (del[i] != LS_NO) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + } +end + + +# XP_RIPLOT -- Plot the reference image intensity versus the input image +# intensity. + +procedure rg_riplot (gd, x, y, resid, npts, datamin, datamax, loreject, + hireject, gmarker, dmarker) + +pointer gd #I pointer to the graphics stream +real x[ARB] #I the x coordinates +real y[ARB] #I the y coordinates +real resid[ARB] #I the residuals array +int npts #I the number of points to be marked +real datamin #I the good data minimum +real datamax #I the good data maximum +real loreject #I the low side rejection limit +real hireject #I the high side rejection limit +int gmarker #I the good point marker type +int dmarker #I the deleted point marker type + +int i + +begin + do i = 1, npts { + if (x[i] < datamin || x[i] > datamax) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else if (y[i] < datamin || y[i] > datamax) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else if (resid[i] < loreject || resid[i] > hireject) + call gmark (gd, x[i], y[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], y[i], gmarker, 2.0, 2.0) + } +end + + +# XP_RRIPLOT -- Plot the reference image intensity versus the input image +# intensity. + +procedure rg_rriplot (gd, x, y, resid, npts, datamin, datamax, loreject, + hireject, gmarker, dmarker) + +pointer gd #I pointer to the graphics stream +real x[ARB] #I the x coordinates +real y[ARB] #I the y coordinates +real resid[ARB] #I the residuals array +int npts #I the number of points to be marked +real datamin #I the good data minimum +real datamax #I the good data maximum +real loreject #I the low side rejection limit +real hireject #I the high side rejection limit +int gmarker #I the good point marker type +int dmarker #I the deleted point marker type + +int i + +begin + do i = 1, npts { + if (x[i] < datamin || x[i] > datamax) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (y[i] < datamin || y[i] > datamax) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (IS_INDEFR(resid[i])) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else if (resid[i] < loreject || resid[i] > hireject) + call gmark (gd, x[i], resid[i], dmarker, 2.0, 2.0) + else + call gmark (gd, x[i], resid[i], gmarker, 2.0, 2.0) + } +end + + +# RG_GALIMR -- Compute the good data limits for the plot. + +procedure rg_galimr (a, index, npts, amin, amax) + +real a[ARB] #I the input array +int index[ARB] #I the index array +int npts #I the size of the array +real amin, amax #O the output min and max values + +int i +real dmin, dmax, gmin, gmax + +begin + dmin = a[1]; dmax = a[1] + gmin = MAX_REAL; gmax = -MAX_REAL + + do i = 1, npts { + if (a[i] < dmin) + dmin = a[i] + else if (a[i] > dmax) + dmax = a[i] + if (index[i] == LS_NO) { + if (a[i] < gmin) + gmin = a[i] + if (a[i] > gmax) + gmax = a[i] + } + } + + if (gmin == MAX_REAL) + amin = dmin + else + amin = gmin + if (gmax == -MAX_REAL) + amax = dmax + else + amax = gmax +end diff --git a/pkg/images/immatch/src/linmatch/rglregions.x b/pkg/images/immatch/src/linmatch/rglregions.x new file mode 100644 index 00000000..16f01b15 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglregions.x @@ -0,0 +1,1084 @@ +include +include +include +include "linmatch.h" + +# RG_LREGIONS -- Decode the input regions description. If the regions string +# is NULL then the regions list is empty. The regions are specified in section +# notation, grid notation, coordinate notation or are read +# from a file. + +int procedure rg_lregions (list, im, ls, rp, reread) + +int list #I pointer to the regions file list +pointer im #I pointer to the reference image +pointer ls #I pointer to the linscale structure +int rp #I region pointer +int reread #I reread the current file + +char fname[SZ_FNAME] +int max_nregions, nregions, fd +pointer sp, regions +int rg_lstati(), rg_lgrid(), rg_lgregions(), rg_lsregions() +int rg_lrsections(), rg_lrcoords(), fntgfnb(), open() +data fname[1] /EOS/ +errchk fntgfnb(), seek(), open(), close() + +begin + call smark (sp) + call salloc (regions, SZ_LINE, TY_CHAR) + + call rg_lstats (ls, REGIONS, Memc[regions], SZ_LINE) + max_nregions = rg_lstati (ls, MAXNREGIONS) + + if (rp < 1 || rp > max_nregions || Memc[regions] == EOS) { + nregions = 0 + } else if (rg_lgrid (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (rg_lgregions (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (rg_lsregions (im, ls, rp, max_nregions) > 0) { + nregions = rg_lstati (ls, NREGIONS) + } else if (list != NULL) { + if (reread == NO) { + iferr { + if (fntgfnb (list, fname, SZ_FNAME) != EOF) { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_lrsections (fd, im, ls, rp, max_nregions) + if (nregions <= 0) { + call seek (fd, BOF) + nregions= rg_lrcoords (fd, im, ls, rp, max_nregions) + } + call close (fd) + } else + nregions = 0 + } then + nregions = 0 + } else if (fname[1] != EOS) { + iferr { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_lrsections (fd, im, ls, rp, max_nregions) + if (nregions <= 0) { + call seek (fd, BOF) + nregions= rg_lrcoords (fd, im, ls, rp, max_nregions) + } + call close (fd) + } then + nregions = 0 + } + } else + nregions = 0 + + call sfree (sp) + + return (nregions) +end + + +# RG_LGRID - Decode the regions from a grid specification. + +int procedure rg_lgrid (im, ls, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer ls #I pointer to the linscale structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int i, istart, iend, j, jstart, jend, ncols, nlines, nxsample, nysample +int nxcols, nylines, nregions +pointer sp, region, section +int rg_lstati(), nscan(), strcmp() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Initialize. + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + + # Decode the grid specification. + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + call gargi (nxsample) + call gargi (nysample) + if ((nscan() != 3) || (strcmp (Memc[section], "grid") != 0)) { + call sfree (sp) + return (nregions) + } + + # Decode the regions. + if ((nxsample * nysample) > max_nregions) { + nxsample = nint (sqrt (real (max_nregions) * real (ncols) / + real (nlines))) + nysample = real (max_nregions) / real (nxsample) + } + nxcols = ncols / nxsample + nylines = nlines / nysample + jstart = 1 + (nlines - nysample * nylines) / 2 + jend = jstart + (nysample - 1) * nylines + do j = jstart, jend, nylines { + istart = 1 + (ncols - nxsample * nxcols) / 2 + iend = istart + (nxsample - 1) * nxcols + do i = istart, iend, nxcols { + Memi[rg_lstatp(ls,RC1)+nregions] = i + Memi[rg_lstatp(ls,RC2)+nregions] = i + nxcols - 1 + Memi[rg_lstatp(ls,RL1)+nregions] = j + Memi[rg_lstatp(ls,RL2)+nregions] = j + nylines - 1 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + call sfree (sp) + + return (nregions) +end + + +# RG_LGREGIONS -- Compute the column and line limits givenan x and y +# coordinate and a default size. + +int procedure rg_lgregions (im, ls, rp, max_nregions) + +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +char comma +int ncols, nlines, nregions, onscan() +int x1, x2, y1, y2 +pointer sp, region +real x, y, xc, yc +int rg_lstati(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the center. + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + onscan = 0 + call sscan (Memc[region]) + call gargr (x) + call gargr (y) + call gargc (comma) + + # Compute the data region. + while ((nscan() == onscan + 3) && (nregions < max_nregions)) { + + # Check for the comma. + if (comma != ',') + break + + # Compute a more accurate center. + #if (rg_lstati (ls, CENTER) == YES) { + #call rg_lcntr (im, x, y, DEF_CRADIUS, xc, yc) + #} else { + xc = x + yc = y + #} + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && + y2 <= IM_LEN(im,2)) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + onscan = nscan() + call gargr (x) + call gargr (y) + call gargc (comma) + } + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + + return (nregions) +end + + +# RG_LMKREGIONS -- Procedure to mark the sections on the image display. +# Sections are marked by pointing the image display cursor to the +# lower left and upper rights corners of the desired sections respectively. + +int procedure rg_lmkregions (fd, im, ls, rp, max_nregions, regions, maxch) + +int fd #I pointer to the output text file +pointer im #I pointer to the image +pointer ls #I pointer to the intensity scaling structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions +char regions[ARB] #O the output regions string +int maxch #I the maximum size of the output string + +int nregions, op, wcs, key +pointer sp, cmd +real xll, yll, xur, yur +int rg_lstati(), clgcur(), gstrcpy() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Initialize. + nregions = min (rp-1, rg_lstati (ls, NREGIONS)) + op = 1 + regions[1] = EOS + + while (nregions < max_nregions) { + + call printf ("Mark lower left corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xll, yll, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + call printf ("Mark upper right corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xur, yur, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Make sure that the region is on the image. + if (xll < 1.0 || xur > IM_LEN(im,1) || yll < 1.0 || yur > + IM_LEN(im,2)) + next + + Memi[rg_lstatp(ls,RC1)+nregions] = nint(xll) + Memi[rg_lstatp(ls,RC2)+nregions] = nint(xur) + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RL1)+nregions] = nint(yll) + Memi[rg_lstatp(ls,RL2)+nregions] = nint(yur) + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + + # Write the regions string. + call sprintf (Memc[cmd], SZ_LINE, "[%d:%d,%d:%d] ") + call pargi (nint(xll)) + call pargi (nint(xur)) + call pargi (nint(yll)) + call pargi (nint(yur)) + op = op + gstrcpy (Memc[cmd], regions[op], maxch - op + 1) + + # Write the output record. + if (fd != NULL) { + call fprintf (fd, "[%d:%d,%d:%d]\n") + call pargi (nint(xll)) + call pargi (nint(xur)) + call pargi (nint(yll)) + call pargi (nint(yur)) + } + } + call printf ("\n") + + # Reallocate the correct amount of space. + call rg_lsets (ls, REGIONS, regions) + call rg_lseti (ls, NREGIONS, nregions) + + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + + return (nregions) +end + + +# RG_LMKXY -- Create a list of objects by selecting objects with +# the image display cursor. + +int procedure rg_lmkxy (fd, im, ls, rp, max_nregions) + +int fd #I the output coordinates file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, wcs, key, x1, x2, y1, y2 +pointer sp, region, cmd +real xc, yc +int clgcur(), rg_lstati() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + nregions = min (rp-1, rg_lstati (ls, NREGIONS)) + while (nregions < max_nregions) { + + # Identify the object. + call printf ("Mark object %d [any key=mark,q=quit]:\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xc, yc, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + if (fd != NULL) { + call fprintf (fd, "%0.3f %0.3f\n") + call pargr (xc) + call pargr (yc) + } + + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + + nregions = nregions + 1 + + } + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) { + call rg_lrealloc (ls, nregions) + if (fd != NULL) { + call fstats (fd, F_FILENAME, Memc[region], SZ_FNAME) + call rg_lsets (ls, REGIONS, Memc[region]) + } else + call rg_lsets (ls, REGIONS, "") + } else { + call rg_lrfree (ls) + call rg_lsets (ls, REGIONS, "") + } + + call sfree (sp) + return (nregions) +end + + +# RG_LRSECTIONS -- Read the sections from a file. + +int procedure rg_lrsections (fd, im, ls, rp, max_nregions) + +int fd #I the regions file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions + +int stat, nregions, ncols, nlines, x1, y1, x2, y2, xstep, ystep +pointer sp, section, line +int rg_lstati(), getline(), rg_lgsections() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the regions string. + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (getline (fd, Memc[line]) != EOF && nregions < max_nregions) { + + call sscan (Memc[line]) + call gargwrd (Memc[section], SZ_LINE) + + while (Memc[section] != EOS && nregions < max_nregions) { + stat = rg_lgsections (Memc[section], x1, x2, xstep, y1, y2, + ystep, ncols, nlines) + + # Check for even dimensioned regions. + if (stat == OK) { + if (mod (x2 - x1 + 1, 2) == 2) { + x2 = x2 + 1 + if (x2 > ncols) + x2 = x2 - 2 + if (x2 < 1) + stat = ERR + } + if (mod (y2 - y1 + 1, 2) == 2) { + y2 = y2 + 1 + if (y2 > nlines) + y2 = y2 - 2 + if (y2 < 1) + stat = ERR + } + } else + stat = ERR + + # Add the new region to the list. + if (stat == OK) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = xstep + Memi[rg_lstatp(ls,RYSTEP)+nregions] = ystep + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + call gargwrd (Memc[section], SZ_LINE) + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LRCOORDS -- Read the coordinates from a file. + +int procedure rg_lrcoords (fd, im, ls, rp, max_nregions) + +int fd #I the regions file descriptor +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, x2, y1, y2 +pointer sp, line +real x, y, xc, yc +int rg_lstati(), getline(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the regions string. + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (getline (fd, Memc[line]) != EOF && nregions < max_nregions) { + + call sscan (Memc[line]) + call gargr (x) + call gargr (y) + if (nscan() != 2) + next + + # Compute a more accurate center. + #if (rg_lstati (ls, CENTER) == YES) { + #call rg_lcntr (im, x, y, DEF_CRADIUS, xc, yc) + #} else { + xc = x + yc = y + #} + + # Compute the data section. + x1 = xc - rg_lstati (ls, DNX) / 2 + x2 = x1 + rg_lstati (ls, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_lstati (ls, DNY) / 2 + y2 = y1 + rg_lstati (ls, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && y2 <= + IM_LEN(im,2)) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LRPHOT -- Read the photometry from a file. + +int procedure rg_lrphot (fd, ls, rp, max_nregions, refimage) + +int fd #I the regions file descriptor +pointer ls #I pointer to the linscale structure +int rp #I pointer to current region +int max_nregions #I the maximum number of regions +int refimage #I is the photometry for the reference image + +int nregions, maxnr +pointer sp, line +real sky, skyerr, mag, magerr +int rg_lstati(), getline(), nscan() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the space to hold the arrays. + if (refimage == YES) { + call rg_lrealloc (ls, max_nregions) + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + maxnr = max_nregions + } else { + nregions = 0 + maxnr = rg_lstati(ls, NREGIONS) + } + + while (getline (fd, Memc[line]) != EOF && nregions < maxnr) { + + call sscan (Memc[line]) + call gargr (sky) + call gargr (skyerr) + call gargr (mag) + call gargr (magerr) + if (nscan() != 4) + next + + Memi[rg_lstatp(ls,RC1)+nregions] = INDEFI + Memi[rg_lstatp(ls,RC2)+nregions] = INDEFI + Memi[rg_lstatp(ls,RL1)+nregions] = INDEFI + Memi[rg_lstatp(ls,RL2)+nregions] = INDEFI + Memi[rg_lstatp(ls,RXSTEP)+nregions] = INDEFI + Memi[rg_lstatp(ls,RYSTEP)+nregions] = INDEFI + + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + if (refimage == YES) { + Memr[rg_lstatp(ls,RSKY)+nregions] = sky + Memr[rg_lstatp(ls,RSKYERR)+nregions] = skyerr + Memr[rg_lstatp(ls,RMAG)+nregions] = mag + Memr[rg_lstatp(ls,RMAGERR)+nregions] = magerr + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + } + + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + if (refimage == NO) { + Memr[rg_lstatp(ls,ISKY)+nregions] = sky + Memr[rg_lstatp(ls,ISKYERR)+nregions] = skyerr + Memr[rg_lstatp(ls,IMAG)+nregions] = mag + Memr[rg_lstatp(ls,IMAGERR)+nregions] = magerr + } + + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + + if (refimage == YES) { + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + } else if (nregions < rg_lstati (ls,NREGIONS)) { + call rg_lseti (ls, NREGIONS, nregions) + } + + call sfree (sp) + return (nregions) +end + + +# RG_LSREGIONS -- Procedure to compute the column and line limits given +# an image section. If the section is the null string then the region list +# is empty. + +int procedure rg_lsregions (im, ls, rp, max_nregions) + +pointer im #I pointer to the image +pointer ls #I pointer to the linscale structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +int ncols, nlines, nregions +int x1, x2, y1, y2, xstep, ystep +pointer sp, section, region +int rg_lstati(), rg_lgsections() +pointer rg_lstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call rg_lstats (ls, REGIONS, Memc[region], SZ_LINE) + + # Allocate the arrays to hold the regions information. + call rg_lrealloc (ls, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (Memc[region] != EOS) { + + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + + nregions = min (rp - 1, rg_lstati (ls, NREGIONS)) + while (Memc[section] != EOS && nregions < max_nregions) { + + # Check for even dimensioned regions. + if (rg_lgsections (Memc[section], x1, x2, xstep, y1, y2, ystep, + ncols, nlines) == OK) { + Memi[rg_lstatp(ls,RC1)+nregions] = x1 + Memi[rg_lstatp(ls,RC2)+nregions] = x2 + Memi[rg_lstatp(ls,RL1)+nregions] = y1 + Memi[rg_lstatp(ls,RL2)+nregions] = y2 + Memi[rg_lstatp(ls,RXSTEP)+nregions] = xstep + Memi[rg_lstatp(ls,RYSTEP)+nregions] = ystep + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + + } else { + Memi[rg_lstatp(ls,RC1)+nregions] = 1 + Memi[rg_lstatp(ls,RC2)+nregions] = ncols + Memi[rg_lstatp(ls,RL1)+nregions] = 1 + Memi[rg_lstatp(ls,RL2)+nregions] = nlines + Memi[rg_lstatp(ls,RXSTEP)+nregions] = 1 + Memi[rg_lstatp(ls,RYSTEP)+nregions] = 1 + Memr[rg_lstatp(ls,RMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,RSKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,RMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RNPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,IMEAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMEDIAN)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMODE)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISIGMA)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKY)+nregions] = INDEFR + Memr[rg_lstatp(ls,ISKYERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAG)+nregions] = INDEFR + Memr[rg_lstatp(ls,IMAGERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,INPTS)+nregions] = INDEFI + Memr[rg_lstatp(ls,RBSCALE)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBSCALEERR)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZERO)+nregions] = INDEFR + Memr[rg_lstatp(ls,RBZEROERR)+nregions] = INDEFR + Memi[rg_lstatp(ls,RDELETE)+nregions] = LS_NO + Memr[rg_lstatp(ls,RCHI)+nregions] = INDEFR + nregions = 1 + } + + + # Reallocate the correct amount of space. + call rg_lseti (ls, NREGIONS, nregions) + if (nregions > 0) + call rg_lrealloc (ls, nregions) + else + call rg_lrfree (ls) + + call sfree (sp) + return (nregions) +end + + +# RG_LGSECTIONS -- Decode an image section into column and line limits +# and a step size. Sections which describe the whole image are decoded into +# a block ncols * nlines long. + +int procedure rg_lgsections (section, x1, x2, xstep, y1, y2, ystep, ncols, + nlines) + +char section[ARB] #I the input section string +int x1, x2 #O the output column section limits +int xstep #O the output column step size +int y1, y2 #O the output line section limits +int ystep #O the output line step size +int ncols, nlines #I the maximum number of lines and columns + +int ip +int rg_lgdim() + +begin + ip = 1 + if (rg_lgdim (section, ip, x1, x2, xstep, ncols) == ERR) + return (ERR) + if (rg_lgdim (section, ip, y1, y2, ystep, nlines) == ERR) + return (ERR) + + return (OK) +end + + +# RG_LGDIM -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +int procedure rg_lgdim (section, ip, x1, x2, step, limit) + +char section[ARB] #I the input image section +int ip #I/O pointer to the position in section string +int x1 #O first limit of dimension +int x2 #O second limit of dimension +int step #O step size of dimension +int limit #I maximum size of dimension + +int temp +int ctoi() + +begin + x1 = 1 + x2 = limit + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] =='[') + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + + # Get X1, X2. + if (ctoi (section, ip, temp) > 0) { # [x1 + x1 = max (1, min (temp, limit)) + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, temp) == 0) # [x1:x2 + return (ERR) + x2 = max (1, min (temp, limit)) + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = limit + x2 = 1 + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, step) == 0) + return (ERR) + else if (step == 0) + return (ERR) + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return (OK) + } else if (section[ip] == ']') + return (OK) + else + return (ERR) +end + + + diff --git a/pkg/images/immatch/src/linmatch/rglscale.x b/pkg/images/immatch/src/linmatch/rglscale.x new file mode 100644 index 00000000..480455ea --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglscale.x @@ -0,0 +1,1337 @@ +include +include +include "linmatch.h" +include "lsqfit.h" + +# RG_LSCALE -- Compute the scaling parameters required to match the +# intensities of an image to a reference image. + +int procedure rg_lscale (imr, im1, db, dformat, ls) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer db #I pointer to the database file +int dformat #I write the output file in database format +pointer ls #I pointer to the linscale structure + +pointer sp, image, imname +real bscale, bzero, bserr, bzerr +bool streq() +int rg_lstati(), fscan(), nscan() + +#int i, nregions +#int rg_isfit () +#pointer rg_istatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call rg_lstats (ls, IMAGE, Memc[image], SZ_FNAME) + + # Initialize. + bscale = 1.0 + bzero = 0.0 + + # Compute the average bscale and bzero for the image either by + # reading it from a file or by computing it directly from the + # data. + + if (rg_lstati(ls, BZALGORITHM) == LS_FILE && rg_lstati (ls, + BSALGORITHM) == LS_FILE) { + + # Read the results of a previous run from the database file or + # a simple text file. + if (dformat == YES) { + call rg_lfile (db, ls, bscale, bzero, bserr, bzerr) + } else { + if (fscan(db) != EOF) { + call gargwrd (Memc[imname], SZ_FNAME) + call gargr (bscale) + call gargr (bzero) + call gargr (bserr) + call gargr (bzerr) + if (! streq (Memc[image], Memc[imname]) || nscan() != 5) { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + } else { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + } + + # Store the values. + call rg_lsetr (ls, TBSCALE, bscale) + call rg_lsetr (ls, TBZERO, bzero) + call rg_lsetr (ls, TBSCALEERR, bserr) + call rg_lsetr (ls, TBZEROERR, bzerr) + + } else { + + # Write out the algorithm parameters. + if (dformat == YES) + call rg_ldbparams (db, ls) + + # Compute the individual scaling factors and their errors for + # all the regions and the average scaling factors and their + # errors. + call rg_scale (imr, im1, ls, bscale, bzero, bserr, bzerr, YES) + + # Write out the results for the individual regions. + if (dformat == YES) + call rg_lwreg (db, ls) + + # Write out the final scaling factors + if (dformat == YES) + call rg_ldbtscale (db, ls) + else { + call fprintf (db, "%s %g %g %g %g\n") + call pargstr (Memc[image]) + call pargr (bscale) + call pargr (bzero) + call pargr (bserr) + call pargr (bzerr) + } + } + + call sfree (sp) + + return (NO) +end + + +# RG_SCALE -- Compute the scaling parameters for a list of regions. + +procedure rg_scale (imr, im1, ls, tbscale, tbzero, tbserr, tbzerr, refit) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer ls #I pointer to the intensity matching structure +real tbscale #O the average scaling parameter +real tbzero #O the average offset parameter +real tbserr #O the average error in the scaling parameter +real tbzerr #O the average error in the offset parameter +int refit #I recompute entire fit, otherwise recompute averages + +int i, nregions, ngood +double sumbscale, sumbzero, sumwbscale, sumbserr, sumbzerr, sumwbzero, dw +real bscale, bzero, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr +int rg_lstati(), rg_limget(), rg_lbszfit() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Determine the number of regions. + nregions = rg_lstati (ls, NREGIONS) + + # Initialize the statistics + sumbscale = 0.0d0 + sumbserr = 0.0d0 + sumwbscale = 0.0d0 + sumbzero = 0.0d0 + sumbzerr = 0.0d0 + sumwbzero = 0.0d0 + ngood = 0 + + # Loop over the regions. + do i = 1, nregions { + + if (refit == YES) { + + # Set the current region. + call rg_lseti (ls, CNREGION, i) + + # Fetch the data for the given region and estimate the mean, + # median, mode, standard deviation, and number of points in + # each region, if this is required by the algorithm. + if (imr != NULL) { + if (rg_limget (ls, imr, im1, i) == ERR) { + call rg_lgmmm (ls, i) + next + } else + call rg_lgmmm (ls, i) + } + + # Compute bscale and bzero and store the results in the + # internal arrays + if (rg_lbszfit (ls, i, bscale, bzero, bserr, bzerr) == ERR) + next + + } else { + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + } + + # Accumulate the weighted sums of the scaling factors. + if (Memi[rg_lstatp(ls,RDELETE)+i-1] == LS_NO && + ! IS_INDEFR(bserr) && ! IS_INDEFR(bzerr)) { + + if (bserr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bserr ** 2 + sumbscale = sumbscale + dw * bscale + sumbserr = sumbserr + dw * bscale * bscale + sumwbscale = sumwbscale + dw + + if (bzerr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bzerr ** 2 + sumbzero = sumbzero + dw * bzero + sumbzerr = sumbzerr + dw * bzero * bzero + sumwbzero = sumwbzero + dw + + ngood = ngood + 1 + } + } + + # Compute the average scaling factors. + call rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bserr, avbscale, avbzero, avbserr, avbzerr, ngood) + + # Perform the rejection cycle. + if (ngood > 2 && rg_lstati(ls, NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || ! IS_INDEFR(rg_lstatr(ls, + HIREJECT)))) { + call rg_ravstats (ls, sumbscale, sumbzero, sumwbscale, sumwbzero, + sumbserr, sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, + avbzerr, ngood) + } + + # Compute the final scaling factors. + if (ngood > 1) { + call rg_lbszavg (ls, avbscale, avbzero, avbserr, avbzerr, + tbscale, tbzero, tbserr, tbzerr) + } else { + tbscale = avbscale + tbzero = avbzero + tbserr = avbserr + tbzerr = avbzerr + } + + # Store the compute values. + call rg_lsetr (ls, TBSCALE, tbscale) + call rg_lsetr (ls, TBZERO, tbzero) + call rg_lsetr (ls, TBSCALEERR, tbserr) + call rg_lsetr (ls, TBZEROERR, tbzerr) +end + + +# RG_LIMGET -- Fetch the reference and input image data and compute the +# statistics for a given region. + +int procedure rg_limget (ls, imr, im1, i) + +pointer ls #I pointer to the intensity scaling structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to image +int i #I the region id + +int stat, nrimcols, nrimlines, nimcols, nimlines, nrcols, nrlines, ncols +int nlines, rc1, rc2, rl1, rl2, c1, c2, l1, l2, xstep, ystep, npts +pointer sp, str, ibuf, rbuf, prc1, prc2, prxstep, prl1, prl2, prystep +int rg_lstati(), rg_simget() +pointer rg_lstatp() +real rg_lstatr() + +#int c1, c2, l1, l2 +#int ncols, nlines, npts + +define nextregion_ 11 + +begin + stat = OK + + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Delete the data of the previous region if any. + rbuf = rg_lstatp (ls, RBUF) + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + rbuf = NULL + ibuf = rg_lstatp (ls, IBUF) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + ibuf = NULL + + # Check for number of regions. + if (i < 1 || i > rg_lstati (ls, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Get the reference and input image sizes. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the reference region pointers. + prc1 = rg_lstatp (ls, RC1) + prc2 = rg_lstatp (ls, RC2) + prl1 = rg_lstatp (ls, RL1) + prl2 = rg_lstatp (ls, RL2) + prxstep = rg_lstatp (ls, RXSTEP) + prystep = rg_lstatp (ls, RYSTEP) + + # Get the reference subraster regions. + rc1 = Memi[prc1+i-1] + rc2 = Memi[prc2+i-1] + rl1 = Memi[prl1+i-1] + rl2 = Memi[prl2+i-1] + xstep = Memi[prxstep+i-1] + ystep = Memi[prystep+i-1] + nrcols = (rc2 - rc1) / xstep + 1 + nrlines = (rl2 - rl1) / ystep + 1 + + # Move to the next region if current reference region is off the image. + if (rc1 < 1 || rc1 > nrimcols || rc2 < 1 || rc2 > nrimcols || + rl1 > nrimlines || rl1 < 1 || rl2 < 1 || rl2 > nrimlines) { + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference region %d: %s[%d:%d:%d,%d:%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (xstep) + call pargi (rl1) + call pargi (rl2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Move to next region if current reference region is too small. + if (nrcols < 3 || (IM_NDIM(imr) == 2 && nrlines < 3)) { + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference region %d: %s[%d:%d:%d,%d:%d:%d] has too few points.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (xstep) + call pargi (rl1) + call pargi (rl2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Get the reference image data. + npts = rg_simget (imr, rc1, rc2, xstep, rl1, rl2, ystep, rbuf) + if (npts < 9) { + stat = ERR + go to nextregion_ + } + call rg_lsetp (ls, RBUF, rbuf) + Memi[rg_lstatp(ls,RNPTS)+i-1] = npts + + # Get the input image subraster regions. + c1 = rc1 + rg_lstatr (ls, SXSHIFT) + c2 = rc2 + rg_lstatr (ls, SXSHIFT) + l1 = rl1 + rg_lstatr (ls, SYSHIFT) + l2 = rl2 + rg_lstatr (ls, SYSHIFT) + #c1 = max (1, min (nimcols, c1)) + #c2 = min (nimcols, max (1, c2)) + #l1 = max (1, min (nimlines, l1)) + #l2 = min (nimlines, max (1, l2)) + ncols = (c2 - c1) / xstep + 1 + nlines = (l2 - l1) / ystep + 1 + + # Move to the next region if current input region is off the image. + if (c1 < 1 || c1 > nimcols || c2 > nimcols || c2 < 1 || + l1 > nimlines || l1 < 1 || l2 < 1 || l2 > nimlines) { + call rg_lstats (ls, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Input region %d: %s[%d:%d:%d,%d:%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (xstep) + call pargi (l1) + call pargi (l2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Move to the next region if current input region is too small. + if (ncols < 3 || (IM_NDIM(im1) == 2 && nlines < 3)) { + call rg_lstats (ls, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Input regions %d: %s[%d:%d:%d,%d:%d:%d] has too few points.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (xstep) + call pargi (l1) + call pargi (l2) + call pargi (ystep) + stat = ERR + goto nextregion_ + } + + # Get the image data. + npts = rg_simget (im1, c1, c2, xstep, l1, l2, ystep, ibuf) + if (npts < 9) { + stat = ERR + go to nextregion_ + } + call rg_lsetp (ls, IBUF, ibuf) + Memi[rg_lstatp(ls,INPTS)+i-1] = npts + + +nextregion_ + call sfree (sp) + if (stat == ERR) { + call rg_lsetp (ls, RBUF, rbuf) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + call rg_lsetp (ls, IBUF, NULL) + call rg_lseti (ls, CNREGION, i) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + return (ERR) + } else { + call rg_lsetp (ls, RBUF, rbuf) + call rg_lsetp (ls, IBUF, ibuf) + call rg_lseti (ls, CNREGION, i) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_NO + return (OK) + } +end + + +# RG_LGMMM -- Compute the mean, median and mode of a data region + +procedure rg_lgmmm (ls, i) + +pointer ls #I pointer to the intensity scaling structure +int i #I the current region + +int npts +pointer rbuf, ibuf, buf +real sigma, dmin, dmax +int rg_lstati() +pointer rg_lstatp() +real rg_lmode(), rg_lstatr() + +begin + # Test that the data buffers exist and contain data. + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + npts = Memi[rg_lstatp (ls, RNPTS)+i-1] + if (rbuf == NULL || npts <= 0) { + Memr[rg_lstatp(ls,RMEAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,RMODE)+i-1] = 0.0 + Memr[rg_lstatp(ls,RSIGMA)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMEAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = 0.0 + Memr[rg_lstatp(ls,IMODE)+i-1] = 0.0 + Memr[rg_lstatp(ls,ISIGMA)+i-1] = 0.0 + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + return + } + call malloc (buf, npts, TY_REAL) + + # Compute the mean, median, and mode of the reference region but + # don't recompute the reference region statistics needlessly. + if ((!IS_INDEFR(rg_lstatr(ls,DATAMIN)) || !IS_INDEFR(rg_lstatr(ls, + DATAMAX))) && (rg_lstati(ls,BSALGORITHM) != LS_FIT || + rg_lstati(ls,BZALGORITHM) != LS_FIT)) { + call alimr (Memr[rbuf], npts, dmin, dmax) + if (!IS_INDEFR(rg_lstatr(ls,DATAMIN))) { + if (dmin < rg_lstatr(ls,DATAMIN)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ( + "Reference region %d contains data < datamin\n") + call pargi (i) + } + } + if (!IS_INDEFR(rg_lstatr(ls,DATAMAX))) { + if (dmax > rg_lstatr(ls,DATAMAX)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ( + "Reference region %d contains data > datamax\n") + call pargi (i) + } + } + } + call aavgr (Memr[rbuf], npts, Memr[rg_lstatp(ls,RMEAN)+i-1], sigma) + Memr[rg_lstatp(ls,RSIGMA)+i-1] = sigma / sqrt (real(npts)) + call asrtr (Memr[rbuf], Memr[buf], npts) + if (mod (npts,2) == 1) + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = Memr[buf+npts/2] + else + Memr[rg_lstatp(ls,RMEDIAN)+i-1] = (Memr[buf+npts/2-1] + + Memr[buf+npts/2]) / 2.0 + Memr[rg_lstatp(ls,RMODE)+i-1] = rg_lmode (Memr[buf], npts, + LMODE_NMIN, LMODE_ZRANGE, LMODE_ZBIN, LMODE_ZSTEP) + sigma = sqrt ((max (Memr[rg_lstatp(ls,RMEAN)+i-1], 0.0) / + rg_lstatr(ls,RGAIN) + (rg_lstatr(ls,RREADNOISE) / + rg_lstatr (ls,RGAIN)) ** 2) / npts) + Memr[rg_lstatp(ls,RSIGMA)+i-1] = + min (Memr[rg_lstatp(ls,RSIGMA)+i-1], sigma) + + if (ibuf == NULL) { + Memr[rg_lstatp(ls,IMEAN)+i-1] = Memr[rg_lstatp(ls,RMEAN)+i-1] + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = Memr[rg_lstatp(ls,RMEDIAN)+i-1] + Memr[rg_lstatp(ls,IMODE)+i-1] = Memr[rg_lstatp(ls,RMODE)+i-1] + Memr[rg_lstatp(ls,ISIGMA)+i-1] = Memr[rg_lstatp(ls,RSIGMA)+i-1] + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call mfree (buf, TY_REAL) + return + } + + # Compute the mean, median, and mode of the input region. + if ((!IS_INDEFR(rg_lstatr(ls,DATAMIN)) || !IS_INDEFR(rg_lstatr(ls, + DATAMAX))) && (rg_lstati(ls,BSALGORITHM) != LS_FIT || + rg_lstati(ls,BZALGORITHM) != LS_FIT)) { + call alimr (Memr[ibuf], npts, dmin, dmax) + if (!IS_INDEFR(rg_lstatr(ls,DATAMIN))) { + if (dmin < rg_lstatr(ls,DATAMIN)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ("Input region %d contains data < datamin\n") + call pargi (i) + } + } + if (!IS_INDEFR(rg_lstatr(ls,DATAMAX))) { + if (dmax > rg_lstatr(ls,DATAMAX)) { + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADREGION + call eprintf ("Input region %d contains data > datamax\n") + call pargi (i) + } + } + } + call aavgr (Memr[ibuf], npts, Memr[rg_lstatp(ls,IMEAN)+i-1], sigma) + Memr[rg_lstatp(ls,ISIGMA)+i-1] = sigma / sqrt (real(npts)) + call asrtr (Memr[ibuf], Memr[buf], npts) + if (mod (npts,2) == 1) + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = Memr[buf+npts/2] + else + Memr[rg_lstatp(ls,IMEDIAN)+i-1] = (Memr[buf+npts/2-1] + + Memr[buf+npts/2]) / 2.0 + Memr[rg_lstatp(ls,IMODE)+i-1] = rg_lmode (Memr[buf], npts, LMODE_NMIN, + LMODE_ZRANGE, LMODE_ZBIN, LMODE_ZSTEP) + sigma = sqrt ((max (Memr[rg_lstatp(ls,IMEAN)+i-1], 0.0) / + rg_lstatr(ls,IGAIN) + (rg_lstatr(ls,IREADNOISE) / + rg_lstatr (ls,IGAIN)) ** 2) / npts) + Memr[rg_lstatp(ls,ISIGMA)+i-1] = + min (Memr[rg_lstatp(ls,ISIGMA)+i-1], sigma) + + + call mfree (buf, TY_REAL) +end + + +# RG_LBSZFIT -- Compute the bscale and bzero factor for a single region. + +int procedure rg_lbszfit (ls, i, bscale, bzero, bserr, bzerr) + +pointer ls #I pointer to the intensity scaling strucuture +int i #I the number of the current region +real bscale #O the computed bscale factor +real bzero #O the computed bzero factor +real bserr #O the computed error in bscale +real bzerr #O the computed error in bzero + +int stat +real bjunk, chi +bool fp_equalr() +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + stat = OK + + # Compute the bscale factor. + switch (rg_lstati (ls, BSALGORITHM)) { + case LS_NUMBER: + bscale = rg_lstatr (ls, CBSCALE) + bserr = 0.0 + chi = INDEFR + case LS_MEAN: + if (fp_equalr (0.0, Memr[rg_lstatp(ls,IMEAN)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = Memr[rg_lstatp(ls, RMEAN)+i-1] / + Memr[rg_lstatp (ls, IMEAN)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp(ls,RMEAN)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMEAN)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / + Memr[rg_lstatp(ls,IMEAN)+i-1]) ** 2) + } + chi = INDEFR + case LS_MEDIAN: + if (fp_equalr (0.0, Memr[rg_lstatp(ls,IMEDIAN)+i-1])) { + bscale = 1.0 + bserr= 0.0 + } else { + bscale = Memr[rg_lstatp (ls,RMEDIAN)+i-1] / + Memr[rg_lstatp(ls,IMEDIAN)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp(ls,RMEDIAN)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMEDIAN)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / Memr[rg_lstatp(ls, + IMEDIAN)+i-1]) ** 2) + } + chi = INDEFR + case LS_MODE: + if (fp_equalr (0.0, Memr[rg_lstatp (ls,IMODE)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = Memr[rg_lstatp (ls, RMODE)+i-1] / + Memr[rg_lstatp (ls, IMODE)+i-1] + if (fp_equalr (0.0, Memr[rg_lstatp (ls,RMODE)+i-1])) + bserr = 0.0 + else + bserr = abs (bscale) * sqrt ((Memr[rg_lstatp(ls, + RSIGMA)+i-1] / Memr[rg_lstatp(ls,RMODE)+i-1]) ** 2 + + (Memr[rg_lstatp(ls, ISIGMA)+i-1] / Memr[rg_lstatp(ls, + IMODE)+i-1]) ** 2) + } + chi = INDEFR + case LS_FIT: + call rg_llsqfit (ls, i, bscale, bzero, bserr, bzerr, chi) + case LS_PHOTOMETRY: + if (IS_INDEFR(Memr[rg_lstatp(ls,RMAG)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,IMAG)+i-1])) { + bscale = 1.0 + bserr = 0.0 + } else { + bscale = 10.0 ** ((Memr[rg_lstatp(ls,IMAG)+i-1] - + Memr[rg_lstatp(ls,RMAG)+i-1]) / 2.5) + if (IS_INDEFR(Memr[rg_lstatp(ls,RMAGERR)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,IMAGERR)+i-1])) + bserr = 0.0 + else + bserr = 0.4 * log (10.0) * bscale * + sqrt (Memr[rg_lstatp(ls,RMAGERR)+i-1] ** 2 + + Memr[rg_lstatp(ls,IMAGERR)+i-1] ** 2) + } + chi = INDEFR + default: + bscale = 1.0 + bserr = 0.0 + chi = INDEFR + } + + # Compute the bzero factor. + switch (rg_lstati (ls, BZALGORITHM)) { + case LS_NUMBER: + bzero = rg_lstatr (ls, CBZERO) + bzerr = 0.0 + chi = INDEFR + case LS_MEAN: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMEAN)+i-1] - Memr[rg_lstatp(ls, + IMEAN)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_MEDIAN: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMEDIAN)+i-1] - + Memr[rg_lstatp(ls,IMEDIAN)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_MODE: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) { + bzero = Memr[rg_lstatp(ls,RMODE)+i-1] - Memr[rg_lstatp(ls, + IMODE)+i-1] + bzerr = sqrt (Memr[rg_lstatp(ls,RSIGMA)+i-1] ** 2 + + Memr[rg_lstatp(ls,ISIGMA)+i-1] ** 2) + } else { + bzero = 0.0 + bzerr = 0.0 + } + chi = INDEFR + case LS_FIT: + if (rg_lstati(ls, BSALGORITHM) == LS_NUMBER) + call rg_llsqfit (ls, i, bjunk, bzero, bjunk, bzerr, chi) + case LS_PHOTOMETRY: + if (IS_INDEFR(Memr[rg_lstatp(ls,RSKY)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,ISKY)+i-1])) { + bzero = 0.0 + bzerr = 0.0 + } else { + bzero = Memr[rg_lstatp(ls,RSKY)+i-1] - bscale * + Memr[rg_lstatp(ls,ISKY)+i-1] + if (IS_INDEFR(Memr[rg_lstatp(ls,RSKYERR)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,ISKYERR)+i-1])) + bzerr = 0.0 + else + bzerr = sqrt (Memr[rg_lstatp(ls,RSKYERR)+i-1] ** 2 + + bserr ** 2 * Memr[rg_lstatp(ls,ISKY)+i-1] ** 2 + + bscale ** 2 * Memr[rg_lstatp(ls,ISKYERR)+i-1] ** 2) + + } + chi = INDEFR + default: + bzero = 0.0 + bzerr = 0.0 + chi = INDEFR + } + + # Store the results. + Memr[rg_lstatp(ls,RBSCALE)+i-1] = bscale + Memr[rg_lstatp(ls,RBZERO)+i-1] = bzero + Memr[rg_lstatp(ls,RBSCALEERR)+i-1] = bserr + Memr[rg_lstatp(ls,RBZEROERR)+i-1] = bzerr + Memr[rg_lstatp(ls,RCHI)+i-1] = chi + + return (stat) +end + + +# RG_LBSZAVG -- Compute the final scaling parameters. + +procedure rg_lbszavg (ls, avbscale, avbzero, avbserr, avbzerr, tbscale, + tbzero, tbserr, tbzerr) + +pointer ls #I pointer to the intensity scaling strucuture +real avbscale #I the computed bscale factor +real avbzero #I the computed bzero factor +real avbserr #I the computed error in bscale +real avbzerr #I the computed error in bzero +real tbscale #O the computed bscale factor +real tbzero #O the computed bzero factor +real tbserr #O the computed error in bscale +real tbzerr #O the computed error in bzero + +int i, bsalg, bzalg, nregions +pointer sp, weight +real answers[MAX_NFITPARS] +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + bsalg = rg_lstati (ls, BSALGORITHM) + bzalg = rg_lstati (ls, BZALGORITHM) + nregions = rg_lstati (ls, NREGIONS) + + call smark (sp) + call salloc (weight, nregions, TY_REAL) + + if (bsalg == LS_MEAN || bzalg == LS_MEAN) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMEAN)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMEAN)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMEAN)], Memr[rg_lstatp(ls, + RMEAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMEAN)], Memr[rg_lstatp(ls, + RMEAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MEAN && bzalg == LS_MEAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MEAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + + } else if (bsalg == LS_MEDIAN || bzalg == LS_MEDIAN) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMEDIAN)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMEDIAN)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMEDIAN)], Memr[rg_lstatp(ls, + RMEDIAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMEDIAN)], Memr[rg_lstatp(ls, + RMEDIAN)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MEDIAN && bzalg == LS_MEDIAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MEDIAN) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + } else if (bsalg == LS_MODE || bzalg == LS_MODE) { + do i = 1, nregions { + if (IS_INDEFR(Memr[rg_lstatp(ls,IMODE)+i-1]) || + IS_INDEFR(Memr[rg_lstatp(ls,RMODE)+i-1]) || + Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + Memr[weight+i-1] = 0.0 + else + Memr[weight+i-1] = 1.0 + } + call ll_lsqf1 (Memr[rg_lstatp(ls,IMODE)], Memr[rg_lstatp(ls, + RMODE)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers) + if (nregions > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) { + call ll_rlsqf1 (Memr[rg_lstatp(ls,IMODE)], Memr[rg_lstatp(ls, + RMODE)], Memr[rg_lstatp(ls,ISIGMA)], Memr[rg_lstatp(ls, + RSIGMA)], Memr[weight], nregions, rg_lstati(ls,MAXITER), + answers, rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + do i = 1, nregions { + if (Memr[weight+i-1] <= 0.0 && Memi[rg_lstatp(ls, + RDELETE)+i-1] == LS_NO) + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + } + } + if (IS_INDEFR(CHI[answers])) { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } else if (bsalg == LS_MODE && bzalg == LS_MODE) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = YINCPT[answers] + tbzerr = EYINCPT[answers] + } else if (bsalg == LS_MODE) { + tbscale = SLOPE[answers] + tbserr = ESLOPE[answers] + tbzero = avbzero + tbzerr = avbzerr + } else { + tbscale = avbscale + tbserr = avbserr + tbzero = avbzero + tbzerr = avbzerr + } + } else { + tbscale = avbscale + tbzero = avbzero + tbserr = avbserr + tbzerr = avbzerr + } + + + call sfree (sp) +end + + +# RG_LFILE -- Fetch the scaling parameters from the datafile. + +procedure rg_lfile (db, ls, bscale, bzero, bserr, bzerr) + +pointer db #I pointer to the database file +pointer ls #I pointer to the intensity scaling structure +real bscale #O the average scaling parameter +real bzero #O the average offset parameter +real bserr #O the error in bscale +real bzerr #O the error in bzero + +int rec +pointer sp, record +int dtlocate() +real dtgetr() + +begin + call smark (sp) + call salloc (record, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, RECORD, Memc[record], SZ_FNAME) + iferr { + rec = dtlocate (db, Memc[record]) + bscale = dtgetr (db, rec, "bscale") + bzero = dtgetr (db, rec, "bzero") + bserr = dtgetr (db, rec, "bserr") + bzerr = dtgetr (db, rec, "bzerr") + } then { + bscale = 1.0 + bzero = 0.0 + bserr = INDEFR + bzerr = INDEFR + } + + call sfree (sp) +end + + +# RG_SIMGET -- Fill a buffer from a specified region of the image including a +# step size in x and y. + +int procedure rg_simget (im, c1, c2, cstep, l1, l2, lstep, ptr) + +pointer im #I the pointer to the iraf image +int c1, c2 #I the column limits +int cstep #I the column step size +int l1, l2 #I the line limits +int lstep #I the line step size +pointer ptr #I the pointer to the output buffer + +int i, j, ncols, nlines, npts +pointer iptr, buf +pointer imgs2r() + +begin + ncols = (c2 - c1) / cstep + 1 + nlines = (l2 - l1) / lstep + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + iptr = ptr + do j = l1, l2, lstep { + buf = imgs2r (im, c1, c2, j, j) + do i = 1, ncols { + Memr[iptr+i-1] = Memr[buf] + buf = buf + cstep + } + iptr = iptr + ncols + } + + return (npts) +end + + +# RG_LMODE -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +real procedure rg_lmode (a, npts, nmin, zrange, fzbin, fzstep) + +real a[npts] #I the sorted input data array +int npts #I the number of points +int nmin #I the minimum number of points +real zrange #I fraction of pixels around median to use +real fzbin #I the bin size for the mode search +real fzstep #I the step size for the mode search + +int x1, x2, x3, nmax +real zstep, zbin, y1, y2, mode +bool fp_equalr() + +begin + # If there are too few points return the median. + if (npts < nmin) { + if (mod (npts,2) == 1) + return (a[1+npts/2]) + else + return ((a[npts/2] + a[1+npts/2]) / 2.0) + } + + # Compute the data range that will be used to do the mode search. + # If the data has no range then the constant value will be returned. + x1 = max (1, int (1.0 + npts * (1.0 - zrange) / 2.0)) + x3 = min (npts, int (1.0 + npts * (1.0 + zrange) / 2.0)) + if (fp_equalr (a[x1], a[x3])) + return (a[x1]) + + # Compute the bin and step size. The bin size is based on the + # data range over a fraction of the pixels around the median + # and a bin step which may be smaller than the bin size. + + zstep = fzstep * (a[x3] - a[x1]) + zbin = fzbin * (a[x3] - a[x1]) + + nmax = 0 + x2 = x1 + for (y1 = a[x1]; x2 < x3; y1 = y1 + zstep) { + for (; a[x1] < y1; x1 = x1 + 1) + ; + y2 = y1 + zbin + for (; (x2 < x3) && (a[x2] < y2); x2 = x2 + 1) + ; + if (x2 - x1 > nmax) { + nmax = x2 - x1 + if (mod (x2+x1,2) == 0) + mode = a[(x2+x1)/2] + else + mode = (a[(x2+x1)/2] + a[(x2+x1)/2+1]) / 2.0 + } + } + + return (mode) +end + + +# RG_LLSQFIT -- Compute the bscale and bzero factors by doing a least squares +# fit to the region data. For this technque to be successful the data must +# be registered and psf matched. + +procedure rg_llsqfit (ls, i, bscale, bzero, bserr, bzerr, chi) + +pointer ls #I pointer to the intensity scaling structure +int i #I the current region +real bscale #O the computed bscale factor +real bzero #O the computed bzero factor +real bserr #O the estimated error in bscale +real bzerr #O the estimated error in bzero +real chi #O the output chi at unit weight + +int j, npts +pointer rbuf, ibuf, rerr, ierr, weight +real rgain, igain, rrnoise, irnoise, answers[MAX_NFITPARS] +real datamin, datamax +int rg_lstati() +pointer rg_lstatp() +real rg_lstatr() + +begin + # Get the data pointers. + rbuf = rg_lstatp (ls, RBUF) + ibuf = rg_lstatp (ls, IBUF) + + # Allocate space for the error and weight arrays. + npts = Memi[rg_lstatp(ls,RNPTS)+i-1] + call malloc (rerr, npts, TY_REAL) + call malloc (ierr, npts, TY_REAL) + call malloc (weight, npts, TY_REAL) + + # Compute the errors. + rgain = rg_lstatr (ls, RGAIN) + igain = rg_lstatr (ls, IGAIN) + rrnoise = rg_lstatr (ls, RREADNOISE) ** 2 / rgain + irnoise = rg_lstatr (ls, IREADNOISE) ** 2 / igain + do j = 1, npts { + Memr[rerr+j-1] = (Memr[rbuf+j-1] + rrnoise) / rgain + Memr[ierr+j-1] = (Memr[ibuf+j-1] + irnoise) / igain + } + + # Compute the weights. + if (IS_INDEFR(rg_lstatr(ls,DATAMIN)) && IS_INDEFR(ls,DATAMAX)) + call amovkr (1.0, Memr[weight], npts) + else { + if (IS_INDEFR(rg_lstatr(ls,DATAMIN))) + datamin = -MAX_REAL + else + datamin = rg_lstatr (ls, DATAMIN) + if (IS_INDEFR(rg_lstatr(ls,DATAMAX))) + datamax = MAX_REAL + else + datamax = rg_lstatr (ls, DATAMAX) + do j = 1, npts { + if (Memr[rbuf+j-1] < datamin || Memr[rbuf+j-1] > datamax) + Memr[weight+j-1] = 0.0 + else if (Memr[ibuf+j-1] < datamin || Memr[ibuf+j-1] > datamax) + Memr[weight+j-1] = 0.0 + else + Memr[weight+j-1] = 1.0 + } + } + + # Compute the fit. + call ll_lsqf1 (Memr[ibuf], Memr[rbuf], Memr[ierr], Memr[rerr], + Memr[weight], npts, rg_lstati(ls, MAXITER), answers) + + # Perform the rejection cycle. + if (npts > 2 && rg_lstati(ls,NREJECT) > 0 && + (! IS_INDEFR(rg_lstatr(ls,LOREJECT)) || + ! IS_INDEFR(rg_lstatr(ls,HIREJECT)))) + call ll_rlsqf1 (Memr[ibuf], Memr[rbuf], Memr[ierr], Memr[rerr], + Memr[weight], npts, rg_lstati(ls,MAXITER), answers, + rg_lstati(ls,NREJECT), rg_lstatr(ls,LOREJECT), + rg_lstatr(ls,HIREJECT)) + bscale = SLOPE[answers] + bzero = YINCPT[answers] + bserr = ESLOPE[answers] + bzerr = EYINCPT[answers] + chi = CHI[answers] + + # Free the working space. + call mfree (rerr, TY_REAL) + call mfree (ierr, TY_REAL) + call mfree (weight, TY_REAL) +end + + +# RG_RAVSTATS -- Compute the average statistics. + +procedure rg_ravstats (ls, sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr, ngood) + +pointer ls #I pointer to the linmatch structure +double sumbscale #I/O sum of the bscale values +double sumbzero #I/O sum of the bzero values +double sumwbscale #I/O sum of the weighted bscale values +double sumwbzero #I/O sum of the weighted bzero values +double sumbserr #I/O sum of the bscale error +double sumbzerr #I/O sum of the bscale error +real bserr #I/O the bscale error of 1 observation +real bzerr #I/O the bzero error of 1 observation +real avbscale #I/O the average bscale factor +real avbzero #I/O the average bzero factor +real avbserr #O the average bscale error factor +real avbzerr #O the average bzero error factor +int ngood #I/O the number of good data values + +int i, nregions, nrej, nbad +real sigbscale, sigbzero, lobscale, hibscale, lobzero, hibzero +real bscale, bzero, bsresid, bzresid +double dw +int rg_lstati() +pointer rg_lstatp() +real rg_lsigma(), rg_lstatr() + +begin + nregions = rg_lstati (ls,NREGIONS) + + nrej = 0 + repeat { + + # Compute sigma. + sigbscale = rg_lsigma (Memr[rg_lstatp(ls,RBSCALE)], + Memi[rg_lstatp(ls,RDELETE)], nregions, avbscale) + if (sigbscale <= 0.0) + break + sigbzero = rg_lsigma (Memr[rg_lstatp(ls,RBZERO)], + Memi[rg_lstatp(ls,RDELETE)], nregions, avbzero) + if (sigbzero <= 0.0) + break + + if (IS_INDEFR(rg_lstatr(ls,LOREJECT))) { + lobscale = -MAX_REAL + lobzero = -MAX_REAL + } else { + lobscale = -sigbscale * rg_lstatr (ls, LOREJECT) + lobzero = -sigbzero * rg_lstatr (ls, LOREJECT) + } + if (IS_INDEFR(rg_lstatr(ls,HIREJECT))) { + hibscale = MAX_REAL + hibzero = MAX_REAL + } else { + hibscale = sigbscale * rg_lstatr (ls, HIREJECT) + hibzero = sigbzero * rg_lstatr (ls, HIREJECT) + } + + nbad = 0 + do i = 1, nregions { + if (Memi[rg_lstatp(ls,RDELETE)+i-1] != LS_NO) + next + bscale = Memr[rg_lstatp(ls,RBSCALE)+i-1] + if (IS_INDEFR(bscale)) + next + bzero = Memr[rg_lstatp(ls,RBZERO)+i-1] + if (IS_INDEFR(bzero)) + next + bserr = Memr[rg_lstatp(ls,RBSCALEERR)+i-1] + bsresid = bscale - avbscale + bzerr = Memr[rg_lstatp(ls,RBZEROERR)+i-1] + bzresid = bzero - avbzero + if (bsresid >= lobscale && bsresid <= hibscale && bzresid >= + lobzero && bzresid <= hibzero) + next + + if (bserr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bserr ** 2 + sumbscale = sumbscale - dw * bscale + sumbserr = sumbserr - dw * bscale * bscale + sumwbscale = sumwbscale - dw + + if (bzerr <= 0.0) + dw = 1.0d0 + else + dw = 1.0d0 / bzerr ** 2 + sumbzero = sumbzero - dw * bzero + sumbzerr = sumbzerr - dw * bzero * bzero + sumwbzero = sumwbzero - dw + + nbad = nbad + 1 + Memi[rg_lstatp(ls,RDELETE)+i-1] = LS_BADSIGMA + ngood = ngood - 1 + } + + if (nbad <= 0) + break + + call rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, + sumbserr, sumbzerr, bserr, bzerr, avbscale, avbzero, + avbserr, avbzerr, ngood) + if (ngood <= 0) + break + + nrej = nrej + 1 + + } until (nrej >= rg_lstati(ls,NREJECT)) +end + + +# RG_AVSTATS -- Compute the average statistics. + +procedure rg_avstats (sumbscale, sumbzero, sumwbscale, sumwbzero, sumbserr, + sumbzerr, bserr, bzerr, avbscale, avbzero, avbserr, avbzerr, ngood) + +double sumbscale #I sum of the bscale values +double sumbzero #I sum of the bzero values +double sumwbscale #I sum of the weighted bscale values +double sumwbzero #I sum of the weighted bzero values +double sumbserr #I sum of the bscale error +double sumbzerr #I sum of the bscale error +real bserr #I the bscale error of 1 observation +real bzerr #I the bzero error of 1 observation +real avbscale #O the average bscale factor +real avbzero #O the average bzero factor +real avbserr #O the average bscale error factor +real avbzerr #O the average bzero error factor +int ngood #I the number of good data values + +begin + # Compute the average scaling factors. + if (ngood > 0) { + avbscale = sumbscale / sumwbscale + if (ngood > 1) { + avbserr = ngood * (sumbserr / sumwbscale - (sumbscale / + sumwbscale) ** 2) / + (ngood - 1) + if (avbserr >= 0.0) + avbserr = sqrt (avbserr) + else + avbserr = 0.0 + } else + avbserr = bserr + avbzero = sumbzero / sumwbzero + if (ngood > 1) { + avbzerr = ngood * (sumbzerr / sumwbzero - (sumbzero / + sumwbzero) ** 2) / + (ngood - 1) + if (avbzerr >= 0.0) + avbzerr = sqrt (avbzerr) + else + avbzerr = 0.0 + } else + avbzerr = bzerr + } else { + avbscale = 1.0 + avbzero = 0.0 + avbserr = INDEFR + avbzerr = INDEFR + } +end + + +# RG_LSIGMA -- Compute the standard deviation of an array taken into +# account any existing deletions. + +real procedure rg_lsigma (a, del, npts, mean) + +real a[ARB] #I the input array +int del[ARB] #I the deletions array +int npts #I the number of points in the array +real mean #I the mean of the array + +int i, ngood +double sumsq + +begin + sumsq = 0.0d0 + ngood = 0 + + do i = 1, npts { + if (del[i] != LS_NO) + next + if (IS_INDEFR(a[i])) + next + sumsq = sumsq + (a[i] - mean) ** 2 + ngood = ngood + 1 + } + + if (ngood <= 1) + return (0.0) + else if (sumsq <= 0.0) + return (0.0) + else + return (sqrt (real (sumsq / (ngood - 1)))) +end diff --git a/pkg/images/immatch/src/linmatch/rglshow.x b/pkg/images/immatch/src/linmatch/rglshow.x new file mode 100644 index 00000000..1bf2c65f --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglshow.x @@ -0,0 +1,107 @@ +include "linmatch.h" + +# RG_LSHOW -- Print the LINMATCH task parameters. + +procedure rg_lshow (ls) + +pointer ls #I pointer to linmatch structure + +pointer sp, str1, str2 +int rg_lstati() +real rg_lstatr() + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + call printf ("\nIntensity Matching Parameters\n") + if (rg_lstati (ls, BSALGORITHM) != LS_PHOTOMETRY && rg_lstati(ls, + BZALGORITHM) != LS_PHOTOMETRY) { + call rg_lstats (ls, IMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REFIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REGIONS, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str1]) + call rg_lstats (ls, CCDGAIN, Memc[str1], SZ_LINE) + call rg_lstats (ls, CCDREAD, Memc[str2], SZ_LINE) + call printf (" %s: %s %s: %s\n") + call pargstr (KY_GAIN) + call pargstr (Memc[str1]) + call pargstr (KY_READNOISE) + call pargstr (Memc[str2]) + } else { + call rg_lstats (ls, IMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, PHOTFILE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_IMAGE) + call pargstr (Memc[str1]) + call rg_lstats (ls, REFIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str1]) + } + call rg_lstats (ls, SHIFTSFILE, Memc[str1], SZ_FNAME) + if (Memc[str1] != EOS) { + call printf (" %s: %s\n") + call pargstr (KY_SHIFTSFILE) + call pargstr (Memc[str1]) + } else { + call printf (" %s: %g %s: %g\n") + call pargstr (KY_XSHIFT) + call pargr (rg_lstatr(ls,XSHIFT)) + call pargstr (KY_YSHIFT) + call pargr (rg_lstatr(ls,YSHIFT)) + } + call printf (" %s: %d %s: %d\n") + call pargstr (KY_DNX) + call pargi (rg_lstati(ls,DNX)) + call pargstr (KY_DNY) + call pargi (rg_lstati(ls,DNY)) + + call rg_lstats (ls, DATABASE, Memc[str1], SZ_FNAME) + call printf (" %s: %s") + call pargstr (KY_DATABASE) + call pargstr (Memc[str1]) + call rg_lstats (ls, OUTIMAGE, Memc[str1], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str1]) + + call rg_lstats (ls, BSSTRING, Memc[str1], SZ_LINE) + call rg_lstats (ls, BZSTRING, Memc[str2], SZ_LINE) + call printf (" %s: %s %s\n") + call pargstr ("scaling") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + call printf (" %s = %g %s = %g") + call pargstr (KY_DATAMIN) + call pargr (rg_lstatr (ls, DATAMIN)) + call pargstr (KY_DATAMAX) + call pargr (rg_lstatr (ls, DATAMAX)) + call printf (" %s: %d\n") + call pargstr (KY_MAXITER) + call pargi (rg_lstati(ls,MAXITER)) + call printf (" %s: %d") + call pargstr (KY_NREJECT) + call pargi (rg_lstati(ls,NREJECT)) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_lstatr (ls, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_lstatr (ls, HIREJECT)) + + call printf ("\n") + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/rglsqfit.x b/pkg/images/immatch/src/linmatch/rglsqfit.x new file mode 100644 index 00000000..f728ecde --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rglsqfit.x @@ -0,0 +1,443 @@ +include +include "lsqfit.h" + +# LL_RLSQF1 -- Given an initial fit reject points outside of the low and +# high cut rejections parameters. + +procedure ll_rlsqf1 (x, y, xerr, yerr, weight, npts, maxiter, answers, nreject, + locut, hicut) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real xerr[ARB] #I the input vector errors squared +real yerr[ARB] #I the reference vector errors squared +real weight[ARB] #I the input weight array +int npts #I the number of points +int maxiter #I the number of iterations +real answers[ARB] #I/O the answers array +int nreject #I the max number of rejection cycles +real locut #I the low side rejection parameter +real hicut #I the high side rejection parameter + +int i, niter, nrej +real loval, hival, resid + +begin + if ((IS_INDEFR(locut) && IS_INDEFR(hicut)) || npts <= 2) + return + if (RMS[answers] <= 0.0 || IS_INDEFR(CHI[answers])) + return + + niter = 0 + repeat { + if (IS_INDEFR(locut)) + loval = -MAX_REAL + else + loval = -locut * RMS[answers] + if (IS_INDEFR(hicut)) + hival = MAX_REAL + else + hival = hicut * RMS[answers] + nrej = 0 + do i = 1, npts { + if (weight[i] <= 0.0) + next + resid = y[i] - (SLOPE[answers] * x[i] + YINCPT[answers]) + if (resid >= loval && resid <= hival) + next + weight[i] = 0.0 + nrej = nrej + 1 + } + if (nrej <= 0) + break + call ll_lsqf1 (x, y, xerr, yerr, weight, npts, maxiter, answers) + if (IS_INDEFR(CHI[answers])) + break + if (RMS[answers] <= 0.0) + break + niter = niter + 1 + } until (niter >= nreject) +end + + +# LL_LSQF1 -- Compute the slope and intercept of the equation y = a * x + b +# using error arrays in both x and y. + +procedure ll_lsqf1 (x, y, xerr, yerr, weight, npts, niter, answers) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real xerr[ARB] #I the input vector errors squared +real yerr[ARB] #I the reference vector errors squared +real weight[ARB] #I the input weight array +int npts #I the number of points +int niter #I the number of iterations +real answers[ARB] #I/O the answers array + +int i, j +pointer bufr, bufx, bufw +real slope, yintrcpt, me1, msq, wt, dm, db + +begin + # Peform the initial fit. + call ll_0lsqf1 (x, y, weight, npts, answers) + if (IS_INDEFR(CHI[answers])) + return + + # Allocate working space. + call malloc (bufr, npts, TY_REAL) + call malloc (bufx, npts, TY_REAL) + call malloc (bufw, npts, TY_REAL) + + # Initialize the iterations. + slope = SLOPE[answers] + yintrcpt = YINCPT[answers] + me1 = CHI[answers] + + # Iterate on the fit. + do i = 1, niter { + msq = slope * slope + do j = 1, npts { + if (weight[j] <= 0.0) { + Memr[bufr+j-1] = 0.0 + Memr[bufw+j-1] = 0.0 + Memr[bufx+j-1] = 0.0 + } else { + wt = yerr[j] + msq * xerr[j] + if (wt <= 0.0) + wt = 1.0 + else + wt = 1.0 / wt + Memr[bufr+j-1] = y[j] - (slope * x[j] + yintrcpt) + Memr[bufw+j-1] = weight[j] * wt + Memr[bufx+j-1] = x[j] + Memr[bufr+j-1] * slope * xerr[j] * + wt + } + } + call ll_0lsqf1 (Memr[bufx], Memr[bufr], Memr[bufw], npts, answers) + if (IS_INDEFR(CHI[answers])) + break + if (abs ((me1 - CHI[answers]) / CHI[answers]) < 1.0e-5) + break + dm = SLOPE[answers] + db = YINCPT[answers] + me1 = CHI[answers] + slope = slope + dm + yintrcpt = yintrcpt + db + } + + # Compute the final answers. + SLOPE[answers] = slope + YINCPT[answers] = yintrcpt + + call mfree (bufr, TY_REAL) + call mfree (bufx, TY_REAL) + call mfree (bufw, TY_REAL) +end + + +# LL_0LSQF1: Compute the slope and intercept of the equation y = a * x + b +# using errors in y only. + +procedure ll_0lsqf1 (x, y, w, npts, answers) + +real x[ARB] #I the input vector +real y[ARB] #I the reference vector +real w[ARB] #I the weight vector +int npts #I the number of points +real answers[ARB] #I the answers + +int i, ngood +double sumyy, sumxx, sumxy, sumx, sumy, sumw +double a, b, det +real wressq, ressq +bool fp_equald() +double ll_dsum1(), ll_dsum2(), ll_dsum3() + +begin + # Compute the determinant. + sumyy = ll_dsum3 (y, y, w, npts) + sumxx = ll_dsum3 (x, x, w, npts) + sumxy = ll_dsum3 (x, y, w, npts) + sumy = ll_dsum2 (y, w, npts) + sumx = ll_dsum2 (x, w, npts) + sumw = ll_dsum1 (w, npts) + det = sumw * sumxx - sumx * sumx + + if (fp_equald (0.0d0, det)) { + SLOPE[answers] = INDEFR + YINCPT[answers] = INDEFR + ESLOPE[answers] = INDEFR + EYINCPT[answers] = INDEFR + CHI[answers] = INDEFR + RMS[answers] = INDEFR + } else { + a = (sumw * sumxy - sumx * sumy) / det + b = (sumxx * sumy - sumx * sumxy) / det + ngood = 0.0 + ressq = 0.0 + do i = 1, npts { + if (w[i] > 0.0) { + ngood = ngood + 1 + ressq = ressq + (y[i] - (a * x[i] + b)) ** 2 + } + } + SLOPE[answers] = a + YINCPT[answers] = b + wressq = sumyy + a * (a * sumxx + 2. * (b * sumx - sumxy)) + + b * (b * sumw - 2.0 * sumy) + if (ngood <= 2) { + CHI[answers] = 0.0 + ESLOPE[answers] = 0.0 + EYINCPT[answers] = 0.0 + RMS[answers] = 0.0 + } else if (wressq >= 0.0) { + CHI[answers] = sqrt (wressq / (ngood - 2)) + ESLOPE[answers] = CHI[answers] * sqrt (real (sumw / abs(det))) + EYINCPT[answers] = CHI[answers] * sqrt (real (sumxx / abs(det))) + RMS[answers] = sqrt (ressq / (ngood - 2)) + } else { + CHI[answers] = 0.0 + ESLOPE[answers] = 0.0 + EYINCPT[answers] = 0.0 + RMS[answers] = 0.0 + } + } +end + + +## GET_LSQF2: iterate LSq Fit to z=ax+by+c for errors in x, y and z. +## NB: xerr, yerr, zerr are errors SQUARED. +## +# +#procedure get_lsqf2 (x, y, z, xerr, yerr, zerr, weight, npts, niter, stats) +# +#real x[npts], y[npts], z[npts] # data vectors +#real xerr[npts], yerr[npts], zerr[npts] # error ** 2 vectors +#real weight[npts] # additional weight factors +#int npts # vector lengths +#int niter # no. of iterations +#real stats[NFITPAR] # returned fit params +# +#int i, j +#real a, b, c, me1 +#pointer bufr, bufx, bufy, bufw +#real asq, bsq, res, wt, da, db, dc +# +#begin +# call malloc (bufr, npts, TY_REAL) +# call malloc (bufx, npts, TY_REAL) +# call malloc (bufy, npts, TY_REAL) +# call malloc (bufw, npts, TY_REAL) +# +## initial fit; NB needs expansion +# call get_0lsqf2 (x, y, z, weight, npts, stats) +# a = SLOPE1[stats] +# b = SLOPE2[stats] +# c = OFFSET[stats] +# me1 = CHI[stats] +## call printf ("iteration: %2d a=%7.4f b=%7.4f off=%6.2f (%7.3f) \n") +## call pargi (0) +## call pargr (a) +## call pargr (b) +## call pargr (c) +## call pargr (me1) +# +## iterate +# do i = 1, niter { +# asq = a * a +# bsq = b * b +# do j = 1, npts { +# res = z[j] - (a * x[j] + b * y[j] + c) +# wt = 1. / (zerr[j] + asq * xerr[j] + bsq * yerr[j]) +# Memr[bufr+j-1] = res +# Memr[bufw+j-1] = weight[j] * wt +# Memr[bufx+j-1] = x[j] + res * a * xerr[j] * wt +# Memr[bufy+j-1] = y[j] + res * b * yerr[j] * wt +# } +# call get_0lsqf2 (Memr[bufx], Memr[bufy], Memr[bufr], Memr[bufw], npts, stats) +# da = SLOPE1[stats] +# db = SLOPE2[stats] +# dc = OFFSET[stats] +# me1 = CHI[stats] +# a = a + da +# b = b + db +# c = c + dc +## call printf ("iteration: %2d a=%7.4f b=%7.4f off=%6.2f (%7.3f) \n") +## call pargi (i) +## call pargr (a) +## call pargr (b) +## call pargr (c) +## call pargr (me1) +# } +# +# SLOPE1[stats] = a +# SLOPE2[stats] = b +# OFFSET[stats] = c +# +# call mfree (bufr, TY_REAL) +# call mfree (bufx, TY_REAL) +# call mfree (bufy, TY_REAL) +# call mfree (bufw, TY_REAL) +#end +# +## +## GET_0LSQF2 -- calculate the zeroth order LLSq Fit for 2 independent variables, +## assumming errors in z only +## +# +# procedure get_0lsqf2 (x, y, z, w, npt, stats) +# +#real x[npt], y[npt] # input coords +#real z[npt] # ref. coord. +#real w[npt] # weights +#int npt # number of points +#real stats[NFITPAR] # fit info struct +# +#real ga[4, 3] +# +#double dsum1(), dsum2(), dsum3() +# +#begin +# ga[1,1] = dsum3 (x, x, w, npt) +# ga[2,1] = dsum3 (x, y, w, npt) +# ga[2,2] = dsum3 (y, y, w, npt) +# ga[3,1] = dsum2 (x, w, npt) +# ga[3,2] = dsum2 (y, w, npt) +# ga[4,1] = dsum3 (x, z, w, npt) +# ga[4,2] = dsum3 (y, z, w, npt) +# ga[4,3] = dsum2 (z, w, npt) +# ga[3,3] = dsum1 (w, npt) +# +# ga[1,2] = ga[2,1] +# ga[1,3] = ga[3,1] +# ga[2,3] = ga[3,2] +# +# call g_elim(ga, 3) +# +# SLOPE1[stats] = ga[4,1] +# SLOPE2[stats] = ga[4,2] +# OFFSET[stats] = ga[4,3] +##need to define errors, me1 +# EOFFSET[stats] = INDEF +# ESLOPE1[stats] = INDEF +# ESLOPE2[stats] = INDEF +# CHI[stats] = INDEF +#end +# + + +# LL_LLSQF0 -- Compute the offset b in the equation y - x = b using error +# arrays in both x and y. + +#procedure ll_lsqf0 (x, y, xerr, yerr, w, npts, answers) + +#real x[ARB] #I the input vector +#real y[ARB] #I the reference vector +#real xerr[ARB] #I the input vector errors squared +#real yerr[ARB] #I the reference vector errors squared +#real w[ARB] #I the input weight vector +#int npts #I the number of points +#real answers[ARB] #I the answer vector + +#double sumxx, sumx, sumw +#pointer bufr, bufw +#double ll_dsum1(), ll_dsum2(), ll_dsum3() + +#begin +# # Allocate working space. +# call malloc (bufr, npts, TY_REAL) +# call malloc (bufw, npts, TY_REAL) +# +# call asubr (y, x, Memr[bufr], npts) +# call aaddr (yerr, xerr, Memr[bufw], npts) +# call adivr (w, Memr[bufw], Memr[bufw], npts) +# +# sumxx = ll_dsum3 (Memr[bufr], Memr[bufr], Memr[bufw], npts) +# sumx = ll_dsum2 (Memr[bufr], Memr[bufw], npts) +# sumw = ll_dsum1 (Memr[bufw], npts) +# +# if (sumw <= 0.0d0) { +# OFFSET[answers] = INDEFR +# EOFFSET[answers] = INDEFR +# CHI[answers] = INDEFR +# } else { +# OFFSET[answers] = sumx / sumw +# if (npts > 1) { +# CHI[answers] = sqrt (real ((sumxx - sumx * sumx / sumw) / +# (npts - 1))) +# EOFFSET[answers] = CHI[answers] / sqrt (real (sumw)) +# } else { +# CHI[answers] = 0.0 +# EOFFSET[answers] = 0.0 +# } +# } +# +# # Free working space. +# call mfree (bufr, TY_REAL) +# call mfree (bufw, TY_REAL) +#end + + +# LL_DSUM1 -- Compute a double precision vector sum. + +double procedure ll_dsum1 (a, n) + +real a[ARB] #I the input vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n + sum = sum + a[i] + + return (sum) +end + + +# LL_DSUM2 -- Compute a double precision vector product. + +double procedure ll_dsum2 (a, b, n) + +real a[n] #I the input vector +real b[n] #I the weight vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n { + if (b[i] > 0.0) + sum = sum + a[i] * b[i] + } + + return (sum) +end + + +# LL_DSUM3 -- Compute a double precision weighted dot product. + + +double procedure ll_dsum3 (a, b, c, n) + +real a[n] #I first input vector +real b[n] #I second input vector +real c[n] #I input weight vector +int n #I the number of points + +double sum +int i + +begin + sum = 0.0d0 + do i = 1, n + if (c[i] > 0.0) + sum = sum + a[i] * b[i] * c[i] + + return (sum) +end diff --git a/pkg/images/immatch/src/linmatch/rgltools.x b/pkg/images/immatch/src/linmatch/rgltools.x new file mode 100644 index 00000000..845a0ac4 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/rgltools.x @@ -0,0 +1,1017 @@ +include "linmatch.h" + +# RG_LINIT -- Initialize the linscale structure. + +procedure rg_linit (ls, max_nregions) + +pointer ls #I/O pointer to the intensity scaling structure +int max_nregions #I the maximum number of regions + +begin + # Allocate the temporary space. + call malloc (ls, LEN_LSSTRUCT, TY_STRUCT) + + # Set up the regions parameters. + LS_NREGIONS(ls) = 0 + LS_CNREGION(ls) = 1 + LS_MAXNREGIONS(ls) = max_nregions + + # Initialize the pointers. + LS_RC1(ls) = NULL + LS_RC2(ls) = NULL + LS_RL1(ls) = NULL + LS_RL2(ls) = NULL + LS_RXSTEP(ls) = NULL + LS_RYSTEP(ls) = NULL + LS_XSHIFT(ls) = 0.0 + LS_YSHIFT(ls) = 0.0 + LS_SXSHIFT(ls) = 0.0 + LS_SYSHIFT(ls) = 0.0 + + LS_RBUF(ls) = NULL + LS_RGAIN(ls) = 1.0 + LS_RREADNOISE(ls) = 0.0 + LS_RMEAN(ls) = NULL + LS_RMEDIAN(ls) = NULL + LS_RMODE(ls) = NULL + LS_RSIGMA(ls) = NULL + LS_RSKY(ls) = NULL + LS_RSKYERR(ls) = NULL + LS_RMAG(ls) = NULL + LS_RMAGERR(ls) = NULL + LS_RNPTS(ls) = NULL + + LS_IBUF(ls) = NULL + LS_IGAIN(ls) = 1.0 + LS_IREADNOISE(ls) = 0.0 + LS_IMEAN(ls) = NULL + LS_IMEDIAN(ls) = NULL + LS_IMODE(ls) = NULL + LS_ISIGMA(ls) = NULL + LS_ISKY(ls) = NULL + LS_ISKYERR(ls) = NULL + LS_IMAG(ls) = NULL + LS_IMAGERR(ls) = NULL + LS_INPTS(ls) = NULL + + LS_RBSCALE(ls) = NULL + LS_RBSCALEERR(ls) = NULL + LS_RBZERO(ls) = NULL + LS_RBZEROERR(ls) = NULL + LS_RDELETE(ls) = NULL + LS_RCHI(ls) = NULL + + # Initialize the scaling algorithm parameters. + LS_BZALGORITHM(ls) = DEF_BZALGORITHM + LS_BSALGORITHM(ls) = DEF_BSALGORITHM + LS_CBZERO(ls) = DEF_CBZERO + LS_CBSCALE(ls) = DEF_CBSCALE + LS_DNX(ls) = DEF_DNX + LS_DNY(ls) = DEF_DNY + LS_MAXITER(ls) = DEF_MAXITER + LS_DATAMIN(ls) = DEF_DATAMIN + LS_DATAMAX(ls) = DEF_DATAMAX + LS_NREJECT(ls) = DEF_NREJECT + LS_LOREJECT(ls) = DEF_LOREJECT + LS_HIREJECT(ls) = DEF_HIREJECT + LS_GAIN(ls) = DEF_GAIN + LS_READNOISE(ls) = DEF_READNOISE + + # Initialize the answers + LS_TBZERO(ls) = 0.0 + LS_TBZEROERR(ls) = INDEFR + LS_TBSCALE(ls) = 1.0 + LS_TBSCALEERR(ls) = INDEFR + + # Initialize the strings. + call strcpy ("mean", LS_BSSTRING(ls), SZ_FNAME) + call strcpy ("mean", LS_BZSTRING(ls), SZ_FNAME) + LS_CCDGAIN(ls) = EOS + LS_CCDREAD(ls) = EOS + LS_IMAGE(ls) = EOS + LS_REFIMAGE(ls) = EOS + LS_REGIONS(ls) = EOS + LS_DATABASE(ls) = EOS + LS_OUTIMAGE(ls) = EOS + LS_RECORD(ls) = EOS + LS_SHIFTSFILE(ls) = EOS + LS_PHOTFILE(ls) = EOS + + # Initialize the buffers. + call rg_lrinit (ls) +end + + +# RG_LRINIT -- Initialize the region dependent part of the linscale structure. + +procedure rg_lrinit (ls) + +pointer ls #I pointer to the intensity scaling structure + +begin + # Free up previously defined region pointers. + call rg_lrfree (ls) + + # Allocate region definition pointers. + call malloc (LS_RC1(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RC2(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RL1(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RL2(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RXSTEP(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RYSTEP(ls), LS_MAXNREGIONS(ls), TY_INT) + + # Allocate region statistics pointers. + call malloc (LS_RMEAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMEDIAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMODE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSIGMA(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSKY(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RSKYERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMAG(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RMAGERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RNPTS(ls), LS_MAXNREGIONS(ls), TY_INT) + + call malloc (LS_IMEAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMEDIAN(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMODE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISIGMA(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISKY(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_ISKYERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMAG(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_IMAGERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_INPTS(ls), LS_MAXNREGIONS(ls), TY_INT) + + call malloc (LS_RBSCALE(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBSCALEERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBZERO(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RBZEROERR(ls), LS_MAXNREGIONS(ls), TY_REAL) + call malloc (LS_RDELETE(ls), LS_MAXNREGIONS(ls), TY_INT) + call malloc (LS_RCHI(ls), LS_MAXNREGIONS(ls), TY_REAL) + + # Initialize region definitions. + call amovki (INDEFI, Memi[LS_RC1(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RC2(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RL1(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RL2(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)], LS_MAXNREGIONS(ls)) + + # Initilaize the statistics. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMODE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSKY(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMAG(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_RNPTS(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMEAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMODE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISKY(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMAG(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (INDEFI, Memi[LS_INPTS(ls)], LS_MAXNREGIONS(ls)) + + # Initialize the answers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)], LS_MAXNREGIONS(ls)) + call amovki (LS_NO, Memi[LS_RDELETE(ls)], LS_MAXNREGIONS(ls)) + call amovkr (INDEFR, Memr[LS_RCHI(ls)], LS_MAXNREGIONS(ls)) +end + + +# RG_LINDEFR -- Re-initialize the regions dependent buffers. + +procedure rg_lindefr (ls) + +pointer ls #I pointer to the intensity scaling structure + +int nregions +int rg_lstati() + +begin + nregions = rg_lstati (ls, NREGIONS) + if (nregions > 0) { + + # Reinitialize the region definition pointers. + call amovki (INDEFI, Memi[LS_RC1(ls)], nregions) + call amovki (INDEFI, Memi[LS_RC2(ls)], nregions) + call amovki (INDEFI, Memi[LS_RL1(ls)], nregions) + call amovki (INDEFI, Memi[LS_RL2(ls)], nregions) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)], nregions) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)], nregions) + + # Reinitialize the statistics pointers. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMODE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSKY(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMAG(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)], nregions) + call amovki (INDEFI, Memi[LS_RNPTS(ls)], nregions) + + call amovkr (INDEFR, Memr[LS_IMEAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMODE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISKY(ls)], nregions) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMAG(ls)], nregions) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)], nregions) + call amovki (INDEFI, Memi[LS_INPTS(ls)], nregions) + + # Reinitialize the answers pointers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)], nregions) + call amovki (LS_NO, Memi[LS_RDELETE(ls)], nregions) + call amovkr (INDEFR, Memr[LS_RCHI(ls)], nregions) + + } +end + + +# RG_LREALLOC -- Reallocate the regions dependent buffers. + +procedure rg_lrealloc (ls, nregions) + +pointer ls #I pointer to the intensity scaling structure +int nregions #I the number of regions + +int nr +int rg_lstati() + +begin + nr = rg_lstati (ls, NREGIONS) + + # Resize the region definition buffers. + call realloc (LS_RC1(ls), nregions, TY_INT) + call realloc (LS_RC2(ls), nregions, TY_INT) + call realloc (LS_RL1(ls), nregions, TY_INT) + call realloc (LS_RL2(ls), nregions, TY_INT) + call realloc (LS_RXSTEP(ls), nregions, TY_INT) + call realloc (LS_RYSTEP(ls), nregions, TY_INT) + + # Resize the statistics buffers. + call realloc (LS_RMEAN(ls), nregions, TY_REAL) + call realloc (LS_RMEDIAN(ls), nregions, TY_REAL) + call realloc (LS_RMODE(ls), nregions, TY_REAL) + call realloc (LS_RSIGMA(ls), nregions, TY_REAL) + call realloc (LS_RSKY(ls), nregions, TY_REAL) + call realloc (LS_RSKYERR(ls), nregions, TY_REAL) + call realloc (LS_RMAG(ls), nregions, TY_REAL) + call realloc (LS_RMAGERR(ls), nregions, TY_REAL) + call realloc (LS_RNPTS(ls), nregions, TY_INT) + + call realloc (LS_IMEAN(ls), nregions, TY_REAL) + call realloc (LS_IMEDIAN(ls), nregions, TY_REAL) + call realloc (LS_IMODE(ls), nregions, TY_REAL) + call realloc (LS_ISIGMA(ls), nregions, TY_REAL) + call realloc (LS_ISKY(ls), nregions, TY_REAL) + call realloc (LS_ISKYERR(ls), nregions, TY_REAL) + call realloc (LS_IMAG(ls), nregions, TY_REAL) + call realloc (LS_IMAGERR(ls), nregions, TY_REAL) + call realloc (LS_INPTS(ls), nregions, TY_INT) + + # Resize the answers buffers. + call realloc (LS_RBSCALE(ls), nregions, TY_REAL) + call realloc (LS_RBSCALEERR(ls), nregions, TY_REAL) + call realloc (LS_RBZERO(ls), nregions, TY_REAL) + call realloc (LS_RBZEROERR(ls), nregions, TY_REAL) + call realloc (LS_RDELETE(ls), nregions, TY_INT) + call realloc (LS_RCHI(ls), nregions, TY_REAL) + + # Reinitialize the region defintions. + call amovki (INDEFI, Memi[LS_RC1(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RC2(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RL1(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RL2(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RXSTEP(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RYSTEP(ls)+nr], nregions - nr) + + # Reinitialize the statistics buffers. + call amovkr (INDEFR, Memr[LS_RMEAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMEDIAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMODE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSIGMA(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSKY(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RSKYERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMAG(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RMAGERR(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_RNPTS(ls)+nr], nregions - nr) + + call amovkr (INDEFR, Memr[LS_IMEAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMEDIAN(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMODE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISIGMA(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISKY(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_ISKYERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMAG(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_IMAGERR(ls)+nr], nregions - nr) + call amovki (INDEFI, Memi[LS_INPTS(ls)+nr], nregions - nr) + + # Reinitialize the answers buffers. + call amovkr (INDEFR, Memr[LS_RBSCALE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBSCALEERR(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBZERO(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RBZEROERR(ls)+nr], nregions - nr) + call amovki (LS_NO, Memi[LS_RDELETE(ls)+nr], nregions - nr) + call amovkr (INDEFR, Memr[LS_RCHI(ls)+nr], nregions - nr) +end + + +# RG_LRFREE -- Free the regions portion of the linscale structure. + +procedure rg_lrfree (ls) + +pointer ls #I pointer to the intensity scaling structure + +begin + LS_NREGIONS(ls) = 0 + + # Free the regions definitions buffers. + if (LS_RC1(ls) != NULL) + call mfree (LS_RC1(ls), TY_INT) + LS_RC1(ls) = NULL + if (LS_RC2(ls) != NULL) + call mfree (LS_RC2(ls), TY_INT) + LS_RC2(ls) = NULL + if (LS_RL1(ls) != NULL) + call mfree (LS_RL1(ls), TY_INT) + LS_RL1(ls) = NULL + if (LS_RL2(ls) != NULL) + call mfree (LS_RL2(ls), TY_INT) + LS_RL2(ls) = NULL + if (LS_RXSTEP(ls) != NULL) + call mfree (LS_RXSTEP(ls), TY_INT) + LS_RXSTEP(ls) = NULL + if (LS_RYSTEP(ls) != NULL) + call mfree (LS_RYSTEP(ls), TY_INT) + LS_RYSTEP(ls) = NULL + + # Free the statistics buffers. + if (LS_RBUF(ls) != NULL) + call mfree (LS_RBUF(ls), TY_REAL) + if (LS_RMEAN(ls) != NULL) + call mfree (LS_RMEAN(ls), TY_REAL) + LS_RMEAN(ls) = NULL + if (LS_RMEDIAN(ls) != NULL) + call mfree (LS_RMEDIAN(ls), TY_REAL) + LS_RMEDIAN(ls) = NULL + if (LS_RMODE(ls) != NULL) + call mfree (LS_RMODE(ls), TY_REAL) + LS_RMODE(ls) = NULL + if (LS_RSIGMA(ls) != NULL) + call mfree (LS_RSIGMA(ls), TY_REAL) + LS_RSIGMA(ls) = NULL + if (LS_RSKY(ls) != NULL) + call mfree (LS_RSKY(ls), TY_REAL) + LS_RSKY(ls) = NULL + if (LS_RSKYERR(ls) != NULL) + call mfree (LS_RSKYERR(ls), TY_REAL) + LS_RSKYERR(ls) = NULL + if (LS_RMAG(ls) != NULL) + call mfree (LS_RMAG(ls), TY_REAL) + LS_RMAG(ls) = NULL + if (LS_RMAGERR(ls) != NULL) + call mfree (LS_RMAGERR(ls), TY_REAL) + LS_RMAGERR(ls) = NULL + if (LS_RNPTS(ls) != NULL) + call mfree (LS_RNPTS(ls), TY_INT) + LS_RNPTS(ls) = NULL + + if (LS_IBUF(ls) != NULL) + call mfree (LS_IBUF(ls), TY_REAL) + if (LS_IMEAN(ls) != NULL) + call mfree (LS_IMEAN(ls), TY_REAL) + LS_IMEAN(ls) = NULL + if (LS_IMEDIAN(ls) != NULL) + call mfree (LS_IMEDIAN(ls), TY_REAL) + LS_IMEDIAN(ls) = NULL + if (LS_IMODE(ls) != NULL) + call mfree (LS_IMODE(ls), TY_REAL) + LS_IMODE(ls) = NULL + if (LS_ISIGMA(ls) != NULL) + call mfree (LS_ISIGMA(ls), TY_REAL) + LS_ISIGMA(ls) = NULL + if (LS_ISKY(ls) != NULL) + call mfree (LS_ISKY(ls), TY_REAL) + LS_ISKY(ls) = NULL + if (LS_ISKYERR(ls) != NULL) + call mfree (LS_ISKYERR(ls), TY_REAL) + LS_ISKYERR(ls) = NULL + if (LS_IMAG(ls) != NULL) + call mfree (LS_IMAG(ls), TY_REAL) + LS_IMAG(ls) = NULL + if (LS_IMAGERR(ls) != NULL) + call mfree (LS_IMAGERR(ls), TY_REAL) + LS_IMAGERR(ls) = NULL + if (LS_INPTS(ls) != NULL) + call mfree (LS_INPTS(ls), TY_INT) + LS_INPTS(ls) = NULL + + # Free the answers buffers. + if (LS_RBSCALE(ls) != NULL) + call mfree (LS_RBSCALE(ls), TY_REAL) + LS_RBSCALE(ls) = NULL + if (LS_RBSCALEERR(ls) != NULL) + call mfree (LS_RBSCALEERR(ls), TY_REAL) + LS_RBSCALEERR(ls) = NULL + if (LS_RBZERO(ls) != NULL) + call mfree (LS_RBZERO(ls), TY_REAL) + LS_RBZERO(ls) = NULL + if (LS_RBZEROERR(ls) != NULL) + call mfree (LS_RBZEROERR(ls), TY_REAL) + LS_RBZEROERR(ls) = NULL + if (LS_RDELETE(ls) != NULL) + call mfree (LS_RDELETE(ls), TY_INT) + LS_RDELETE(ls) = NULL + if (LS_RCHI(ls) != NULL) + call mfree (LS_RCHI(ls), TY_REAL) + LS_RCHI(ls) = NULL +end + + +# RG_LFREE -- Free the linscale structure. + +procedure rg_lfree (ls) + +pointer ls #I/O pointer to the intensity scaling structure + +begin + # Free the regions dependent pointers. + call rg_lrfree (ls) + + call mfree (ls, TY_STRUCT) +end + + +# RG_LSTATI -- Fetch the value of an integer parameter. + +int procedure rg_lstati (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + case CNREGION: + return (LS_CNREGION(ls)) + case NREGIONS: + return (LS_NREGIONS(ls)) + case MAXNREGIONS: + return (LS_MAXNREGIONS(ls)) + case BZALGORITHM: + return (LS_BZALGORITHM(ls)) + case BSALGORITHM: + return (LS_BSALGORITHM(ls)) + case DNX: + return (LS_DNX(ls)) + case DNY: + return (LS_DNY(ls)) + case MAXITER: + return (LS_MAXITER(ls)) + case NREJECT: + return (LS_NREJECT(ls)) + default: + call error (0, "RG_LSTATI: Unknown integer parameter.") + } +end + + +# RG_LSTATP -- Fetch the value of a pointer parameter. + +pointer procedure rg_lstatp (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + + case RC1: + return (LS_RC1(ls)) + case RC2: + return (LS_RC2(ls)) + case RL1: + return (LS_RL1(ls)) + case RL2: + return (LS_RL2(ls)) + case RXSTEP: + return (LS_RXSTEP(ls)) + case RYSTEP: + return (LS_RYSTEP(ls)) + + case RBUF: + return (LS_RBUF(ls)) + case RMEAN: + return (LS_RMEAN(ls)) + case RMEDIAN: + return (LS_RMEDIAN(ls)) + case RMODE: + return (LS_RMODE(ls)) + case RSIGMA: + return (LS_RSIGMA(ls)) + case RSKY: + return (LS_RSKY(ls)) + case RSKYERR: + return (LS_RSKYERR(ls)) + case RMAG: + return (LS_RMAG(ls)) + case RMAGERR: + return (LS_RMAGERR(ls)) + case RNPTS: + return (LS_RNPTS(ls)) + + case IBUF: + return (LS_IBUF(ls)) + case IMEAN: + return (LS_IMEAN(ls)) + case IMEDIAN: + return (LS_IMEDIAN(ls)) + case IMODE: + return (LS_IMODE(ls)) + case ISIGMA: + return (LS_ISIGMA(ls)) + case ISKY: + return (LS_ISKY(ls)) + case ISKYERR: + return (LS_ISKYERR(ls)) + case IMAG: + return (LS_IMAG(ls)) + case IMAGERR: + return (LS_IMAGERR(ls)) + case INPTS: + return (LS_INPTS(ls)) + + case RBSCALE: + return (LS_RBSCALE(ls)) + case RBSCALEERR: + return (LS_RBSCALEERR(ls)) + case RBZERO: + return (LS_RBZERO(ls)) + case RBZEROERR: + return (LS_RBZEROERR(ls)) + case RDELETE: + return (LS_RDELETE(ls)) + case RCHI: + return (LS_RCHI(ls)) + + default: + call error (0, "RG_LSTATP: Unknown pointer parameter.") + } +end + + +# RG_LSTATR -- Fetch the value of a real parameter. + +real procedure rg_lstatr (ls, param) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched + +begin + switch (param) { + + case XSHIFT: + return (LS_XSHIFT(ls)) + case YSHIFT: + return (LS_YSHIFT(ls)) + case SXSHIFT: + return (LS_SXSHIFT(ls)) + case SYSHIFT: + return (LS_SYSHIFT(ls)) + + case CBZERO: + return (LS_CBZERO(ls)) + case CBSCALE: + return (LS_CBSCALE(ls)) + case DATAMIN: + return (LS_DATAMIN(ls)) + case DATAMAX: + return (LS_DATAMAX(ls)) + case LOREJECT: + return (LS_LOREJECT(ls)) + case HIREJECT: + return (LS_HIREJECT(ls)) + case GAIN: + return (LS_GAIN(ls)) + case RGAIN: + return (LS_RGAIN(ls)) + case IGAIN: + return (LS_IGAIN(ls)) + case READNOISE: + return (LS_READNOISE(ls)) + case RREADNOISE: + return (LS_RREADNOISE(ls)) + case IREADNOISE: + return (LS_IREADNOISE(ls)) + + case TBZERO: + return (LS_TBZERO(ls)) + case TBZEROERR: + return (LS_TBZEROERR(ls)) + case TBSCALE: + return (LS_TBSCALE(ls)) + case TBSCALEERR: + return (LS_TBSCALEERR(ls)) + + default: + call error (0, "RG_LSTATR: Unknown real parameter.") + } +end + + +# RG_LSTATS -- Fetch the value of a string parameter. + +procedure rg_lstats (ls, param, str, maxch) + +pointer ls #I pointer to the intensity scaling structure +int param #I parameter to be fetched +char str[ARB] #I the output string +int maxch #I maximum number of characters + +begin + switch (param) { + case BZSTRING: + call strcpy (LS_BZSTRING(ls), str, maxch) + case BSSTRING: + call strcpy (LS_BSSTRING(ls), str, maxch) + case CCDGAIN: + call strcpy (LS_CCDGAIN(ls), str, maxch) + case CCDREAD: + call strcpy (LS_CCDREAD(ls), str, maxch) + case IMAGE: + call strcpy (LS_IMAGE(ls), str, maxch) + case REFIMAGE: + call strcpy (LS_REFIMAGE(ls), str, maxch) + case REGIONS: + call strcpy (LS_REGIONS(ls), str, maxch) + case DATABASE: + call strcpy (LS_DATABASE(ls), str, maxch) + case OUTIMAGE: + call strcpy (LS_OUTIMAGE(ls), str, maxch) + case SHIFTSFILE: + call strcpy (LS_SHIFTSFILE(ls), str, maxch) + case PHOTFILE: + call strcpy (LS_PHOTFILE(ls), str, maxch) + case RECORD: + call strcpy (LS_RECORD(ls), str, maxch) + default: + call error (0, "RG_LSTATS: Unknown string parameter.") + } +end + + +# RG_LSETI -- Set the value of an integer parameter. + +procedure rg_lseti (ls, param, value) + +pointer ls # pointer to the intensity scaling structure +int param # parameter to be fetched +int value # value of the integer parameter + +begin + switch (param) { + + case NREGIONS: + LS_NREGIONS(ls) = value + case CNREGION: + LS_CNREGION(ls) = value + case MAXNREGIONS: + LS_MAXNREGIONS(ls) = value + + case BZALGORITHM: + LS_BZALGORITHM(ls) = value + switch (value) { + case LS_MEAN: + call strcpy ("mean", LS_BZSTRING(ls), SZ_FNAME) + case LS_MEDIAN: + call strcpy ("median", LS_BZSTRING(ls), SZ_FNAME) + case LS_MODE: + call strcpy ("mode", LS_BZSTRING(ls), SZ_FNAME) + case LS_FIT: + call strcpy ("fit", LS_BZSTRING(ls), SZ_FNAME) + case LS_PHOTOMETRY: + call strcpy ("photometry", LS_BZSTRING(ls), SZ_FNAME) + case LS_NUMBER: + ; + case LS_FILE: + call strcpy ("file", LS_BZSTRING(ls), SZ_FNAME) + LS_BSALGORITHM(ls) = value + call strcpy ("file", LS_BSSTRING(ls), SZ_FNAME) + default: + LS_BZALGORITHM(ls) = LS_NUMBER + call strcpy ("0.0", LS_BZSTRING(ls), SZ_FNAME) + LS_CBZERO(ls) = 0.0 + } + + case BSALGORITHM: + LS_BSALGORITHM(ls) = value + switch (value) { + case LS_MEAN: + call strcpy ("mean", LS_BSSTRING(ls), SZ_FNAME) + case LS_MEDIAN: + call strcpy ("median", LS_BSSTRING(ls), SZ_FNAME) + case LS_MODE: + call strcpy ("mode", LS_BSSTRING(ls), SZ_FNAME) + case LS_FIT: + call strcpy ("fit", LS_BSSTRING(ls), SZ_FNAME) + case LS_PHOTOMETRY: + call strcpy ("photometry", LS_BSSTRING(ls), SZ_FNAME) + case LS_NUMBER: + ; + case LS_FILE: + call strcpy ("file", LS_BSSTRING(ls), SZ_FNAME) + LS_BZALGORITHM(ls) = value + call strcpy ("file", LS_BZSTRING(ls), SZ_FNAME) + default: + LS_BSALGORITHM(ls) = LS_NUMBER + call strcpy ("1.0", LS_BSSTRING(ls), SZ_FNAME) + LS_CBSCALE(ls) = 1.0 + } + + case DNX: + LS_DNX(ls) = value + case DNY: + LS_DNY(ls) = value + case MAXITER: + LS_MAXITER(ls) = value + case NREJECT: + LS_NREJECT(ls) = value + + default: + call error (0, "RG_LSETI: Unknown integer parameter.") + } +end + + +# RG_LSETP -- Set the value of a pointer parameter. + +procedure rg_lsetp (ls, param, value) + +pointer ls #I pointer to the linscale structure +int param #I parameter to be fetched +pointer value #I value of the pointer parameter + +begin + switch (param) { + + case RC1: + LS_RC1(ls) = value + case RC2: + LS_RC2(ls) = value + case RL1: + LS_RL1(ls) = value + case RL2: + LS_RL2(ls) = value + case RXSTEP: + LS_RXSTEP(ls) = value + case RYSTEP: + LS_RYSTEP(ls) = value + + case RBUF: + LS_RBUF(ls) = value + case RMEAN: + LS_RMEAN(ls) = value + case RMEDIAN: + LS_RMEDIAN(ls) = value + case RMODE: + LS_RMODE(ls) = value + case RSIGMA: + LS_RSIGMA(ls) = value + case RSKY: + LS_RSKY(ls) = value + case RSKYERR: + LS_RSKYERR(ls) = value + case RMAG: + LS_RMAG(ls) = value + case RMAGERR: + LS_RMAGERR(ls) = value + case RNPTS: + LS_RNPTS(ls) = value + + case IBUF: + LS_IBUF(ls) = value + case IMEAN: + LS_IMEAN(ls) = value + case IMEDIAN: + LS_IMEDIAN(ls) = value + case IMODE: + LS_IMODE(ls) = value + case ISIGMA: + LS_ISIGMA(ls) = value + case ISKY: + LS_ISKY(ls) = value + case ISKYERR: + LS_ISKYERR(ls) = value + case IMAG: + LS_IMAG(ls) = value + case IMAGERR: + LS_IMAGERR(ls) = value + case INPTS: + LS_INPTS(ls) = value + + case RBSCALE: + LS_RBSCALE(ls) = value + case RBSCALEERR: + LS_RBSCALEERR(ls) = value + case RBZERO: + LS_RBZERO(ls) = value + case RBZEROERR: + LS_RBZEROERR(ls) = value + case RDELETE: + LS_RDELETE(ls) = value + case RCHI: + LS_RCHI(ls) = value + + default: + call error (0, "RG_LSETP: Unknown pointer parameter.") + } +end + + +# RG_LSETR -- Set the value of a real parameter. + +procedure rg_lsetr (ls, param, value) + +pointer ls #I pointer to iscale structure +int param #I parameter to be fetched +real value #I real parameter + +begin + switch (param) { + case XSHIFT: + LS_XSHIFT(ls) = value + case YSHIFT: + LS_YSHIFT(ls) = value + case SXSHIFT: + LS_SXSHIFT(ls) = value + case SYSHIFT: + LS_SYSHIFT(ls) = value + case CBZERO: + LS_CBZERO(ls) = value + case CBSCALE: + LS_CBSCALE(ls) = value + case DATAMIN: + LS_DATAMIN(ls) = value + case DATAMAX: + LS_DATAMAX(ls) = value + case LOREJECT: + LS_LOREJECT(ls) = value + case HIREJECT: + LS_HIREJECT(ls) = value + case GAIN: + LS_GAIN(ls) = value + case RGAIN: + LS_RGAIN(ls) = value + case IGAIN: + LS_IGAIN(ls) = value + case READNOISE: + LS_READNOISE(ls) = value + case RREADNOISE: + LS_RREADNOISE(ls) = value + case IREADNOISE: + LS_IREADNOISE(ls) = value + case TBSCALE: + LS_TBSCALE(ls) = value + case TBSCALEERR: + LS_TBSCALEERR(ls) = value + case TBZERO: + LS_TBZERO(ls) = value + case TBZEROERR: + LS_TBZEROERR(ls) = value + default: + call error (0, "RG_LSETR: Unknown real parameter.") + } +end + + +# RG_LSETS -- Set the value of a string parameter. + +procedure rg_lsets (ls, param, str) + +pointer ls # pointer to the intensity scaling structure +int param # parameter to be fetched +char str[ARB] # output string + +int index, ip +pointer sp, temp +real rval +int fnldir(), strdic(), ctor(), rg_lstati() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + switch (param) { + + case BZSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, LS_SCALING) + if (index > 0) { + if (rg_lstati (ls, BSALGORITHM) == LS_NUMBER) { + call strcpy (str, LS_BZSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BZALGORITHM, index) + } else { + call strcpy (LS_BSSTRING(ls), LS_BZSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BZALGORITHM, rg_lstati (ls, BSALGORITHM)) + } + } else if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_BZSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBZERO, rval) + call rg_lseti (ls, BZALGORITHM, LS_NUMBER) + } else { + call strcpy ("0.0", LS_BZSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBZERO, 0.0) + call rg_lseti (ls, BZALGORITHM, LS_NUMBER) + } + case BSSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, LS_SCALING) + if (index > 0) { + call strcpy (str, LS_BSSTRING(ls), SZ_FNAME) + call rg_lseti (ls, BSALGORITHM, index) + } else if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_BSSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBSCALE, rval) + call rg_lseti (ls, BSALGORITHM, LS_NUMBER) + } else { + call strcpy ("1.0", LS_BSSTRING(ls), SZ_FNAME) + call rg_lsetr (ls, CBSCALE, 1.0) + call rg_lseti (ls, BSALGORITHM, LS_NUMBER) + } + case CCDGAIN: + ip = 1 + if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_CCDGAIN(ls), SZ_FNAME) + call rg_lsetr (ls, RGAIN, rval) + if (ctor (str, ip, rval) > 0) + call rg_lsetr (ls, IGAIN, rval) + else + call rg_lsetr (ls, IGAIN, 1.0) + call rg_lsetr (ls, GAIN, INDEFR) + } else { + call sscan (str) + call gargwrd (Memc[temp], SZ_LINE) + call strcpy (Memc[temp], LS_CCDGAIN(ls), SZ_FNAME) + call rg_lsetr (ls, RGAIN, 1.0) + call rg_lsetr (ls, IGAIN, 1.0) + call rg_lsetr (ls, GAIN, INDEFR) + } + case CCDREAD: + ip = 1 + if (ctor (str, ip, rval) > 0) { + call strcpy (str, LS_CCDREAD(ls), SZ_FNAME) + call rg_lsetr (ls, RREADNOISE, rval) + if (ctor (str, ip, rval) > 0) + call rg_lsetr (ls, IREADNOISE, rval) + else + call rg_lsetr (ls, IREADNOISE, 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + } else { + call sscan (str) + call gargwrd (Memc[temp], SZ_LINE) + call strcpy (Memc[temp], LS_CCDREAD(ls), SZ_FNAME) + call rg_lsetr (ls, RREADNOISE, 0.0) + call rg_lsetr (ls, IREADNOISE, 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + } + + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], LS_IMAGE(ls), SZ_FNAME) + call strcpy (Memc[temp+index], LS_IMAGE(ls), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], LS_REFIMAGE(ls), SZ_FNAME) + call strcpy (Memc[temp+index], LS_REFIMAGE(ls), SZ_FNAME) + case REGIONS: + call strcpy (str, LS_REGIONS(ls), SZ_FNAME) + case DATABASE: + index = fnldir (str, LS_DATABASE(ls), SZ_FNAME) + call strcpy (str[index+1], LS_DATABASE(ls), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, LS_OUTIMAGE(ls), SZ_FNAME) + case SHIFTSFILE: + call strcpy (str, LS_SHIFTSFILE(ls), SZ_FNAME) + case PHOTFILE: + call strcpy (str, LS_PHOTFILE(ls), SZ_FNAME) + case RECORD: + call strcpy (str, LS_RECORD(ls), SZ_FNAME) + + default: + call error (0, "RG_LSETS: Unknown string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/linmatch/t_linmatch.x b/pkg/images/immatch/src/linmatch/t_linmatch.x new file mode 100644 index 00000000..d48f2c03 --- /dev/null +++ b/pkg/images/immatch/src/linmatch/t_linmatch.x @@ -0,0 +1,544 @@ +include +include +include +include +include "linmatch.h" + +# T_LINMATCH -- Compute the parameters required to match the intensity scale +# of an image to that of a reference image using an expression of the form +# I(ref) = a + b * I(image) + +procedure t_linmatch() + +pointer freglist #I pointer to reference regions list +pointer database #I pointer to database file +int dformat #I write the output file in database format +int interactive #I interactive mode ? +int verbose #I verbose mode + +int list1, listr, list2, reglist, reclist, stat, nregions, shiftslist +int rpfd, ipfd, sfd +pointer sp, reference, imager, image1, imtemp, image2, str, str1, shifts +pointer ls, db, gd, id, imr, im1, im2 +bool clgetb() +int imtopen(), fntopnb(), imtlen(), fntlenb(), access(), btoi(), open() +int rg_lstati(), imtgetim(), fntgfnb(), rg_lregions(), rg_lscale() +int rg_lrphot(), rg_liscale() +pointer dtmap(), gopen(), immap() +real rg_lstatr() +errchk gopen() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + + call salloc (reference, SZ_FNAME, TY_CHAR) + call salloc (freglist, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (shifts, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (str1, SZ_LINE, TY_CHAR) + + # Open the input and output image lists. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[reference], SZ_LINE) + call clgstr ("regions", Memc[freglist], SZ_LINE) + call clgstr ("lintransform", Memc[database], SZ_LINE) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + call clgstr ("records", Memc[str], SZ_LINE) + if (Memc[str] == EOS) + reclist = NULL + else + reclist = fntopnb (Memc[str], NO) + call clgstr ("shifts", Memc[shifts], SZ_LINE) + + + # Open the cross correlation fitting structure. + call rg_glpars (ls) + + # Test the reference image list length + if ((rg_lstati (ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls, BZALGORITHM) == + LS_NUMBER && rg_lstati(ls, BSALGORITHM) == LS_NUMBER)) { + listr = NULL + reglist = NULL + shiftslist = NULL + call rg_lsets (ls, REGIONS, "") + } else if (rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati (ls, + BSALGORITHM) == LS_PHOTOMETRY) { + listr = fntopnb (Memc[reference], NO) + if (fntlenb (listr) <= 0) + call error (0, "The reference photometry list is empty.") + reglist = fntopnb (Memc[freglist], NO) + if (fntlenb (listr) > 1 && fntlenb (listr) != imtlen (list1)) { + call eprintf ("The number of reference photometry files") + call eprintf (" and input images is not the same.\n") + call erract (EA_FATAL) + } + if (fntlenb(reglist) != imtlen(list1)) { + call eprintf ("The number of input photometry files and") + call eprintf ("images are not the same.\n") + call erract (EA_FATAL) + } + shiftslist = NULL + call rg_lsets (ls, REGIONS, Memc[freglist]) + } else { + listr = imtopen (Memc[reference]) + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + iferr { + reglist = fntopnb (Memc[freglist], NO) + } then + reglist = NULL + if (Memc[shifts] == EOS) + shiftslist = NULL + else { + shiftslist = fntopnb (Memc[shifts], NO) + if (imtlen(listr) != fntlenb (shiftslist)) + call error (0, + "The number of shifts files and images is not the same.") + } + call rg_lsets (ls, REGIONS, Memc[freglist]) + } + + + # Close the output image list if it is empty. + if (imtlen (list2) <= 0) { + call imtclose (list2) + list2 = NULL + } + + # Check that the output image list is the same as the input image + # list. + if (list2 != NULL) { + if (imtlen (list1) != imtlen (list2)) + call error (0, + "The number of input and output images are not the same.") + } + + # Check that the record list is the same length as the input image + # list length. + if (reclist != NULL) { + if (fntlenb (reclist) != imtlen (list1)) + call error (0, + "Input image and record lists are not the same length") + } + + # Open the database file. + dformat = btoi (clgetb ("databasefmt")) + if (rg_lstati(ls, BZALGORITHM) == LS_FILE && rg_lstati(ls, + BSALGORITHM) == LS_FILE) { + if (dformat == YES) + db = dtmap (Memc[database], READ_ONLY) + else + db = open (Memc[database], READ_ONLY, TEXT_FILE) + } else if (clgetb ("append")) { + if (dformat == YES) + db = dtmap (Memc[database], APPEND) + else + db = open (Memc[database], NEW_FILE, TEXT_FILE) + } else if (access(Memc[database], 0, 0) == YES) { + call error (0, "The shifts database file already exists") + } else { + if (dformat == YES) + db = dtmap (Memc[database], NEW_FILE) + else + db = open (Memc[database], NEW_FILE, TEXT_FILE) + } + call rg_lsets (ls, DATABASE, Memc[database]) + + if ((rg_lstati(ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls, BZALGORITHM) == + LS_NUMBER && rg_lstati(ls, BSALGORITHM) == LS_NUMBER)) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + # Initialize the reference image pointer. + imr = NULL + sfd = NULL + rpfd = NULL + ipfd = NULL + + # Do each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open the reference image and associated regions files + # if the correlation function is not file. + if (rg_lstati(ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati(ls, + BSALGORITHM) == LS_PHOTOMETRY) { + if (fntgfnb(listr, Memc[str], SZ_FNAME) != EOF) { + if (rpfd != NULL) + call close (rpfd) + rpfd = open (Memc[str], READ_ONLY, TEXT_FILE) + call rg_lsets (ls, REFIMAGE, Memc[str]) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + nregions = rg_lrphot (rpfd, ls, 1, rg_lstati(ls, + MAXNREGIONS), YES) + if (nregions <= 0 && interactive == NO) + call error (0, + "The reference photometry file is empty.") + } + } else if ((rg_lstati(ls, BZALGORITHM) == LS_FILE || rg_lstati(ls, + BSALGORITHM) == LS_FILE) || (rg_lstati(ls,BZALGORITHM) == + LS_NUMBER && rg_lstati(ls,BSALGORITHM) == LS_NUMBER)) { + call rg_lsets (ls, REFIMAGE, "reference") + } else { + if (imtgetim(listr, Memc[str], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Referenc image must be 1D or 2D") + call rg_lgain (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, RGAIN, rg_lstatr (ls,GAIN)) + call rg_lrdnoise (imr, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, RREADNOISE, rg_lstatr (ls,READNOISE)) + call rg_lsets (ls, REFIMAGE, Memc[str]) + nregions = rg_lregions (reglist, imr, ls, 1, NO) + if (nregions <= 0 && interactive == NO) + call error (0, "The regions list is empty.") + if (shiftslist != NULL) { + if (sfd != NULL) + call close (sfd) + if (fntgfnb (shiftslist, Memc[str], SZ_FNAME) == EOF) { + call rg_lsets (ls, SHIFTSFILE, "") + sfd = NULL + } else { + call rg_lsets (ls, SHIFTSFILE, Memc[str]) + sfd = open (Memc[str], READ_ONLY, TEXT_FILE) + } + } + } + } + + # Open the input image. + if (list2 == NULL && imr == NULL) + im1 = NULL + else { + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input images must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) { + call eprintf ("Input images must have same") + call eprintf (" dimensionality as reference images.\n") + call erract (EA_FATAL) + } + } + call rg_lgain (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,GAIN))) + call rg_lsetr (ls, IGAIN, rg_lstatr (ls, GAIN)) + call rg_lrdnoise (im1, ls) + if (!IS_INDEFR(rg_lstatr(ls,READNOISE))) + call rg_lsetr (ls, IREADNOISE, rg_lstatr (ls, READNOISE)) + } + call rg_lsets (ls, IMAGE, Memc[image1]) + + # Open the input photometry file. + if (rpfd != NULL) { + if (fntgfnb (reglist, Memc[str], SZ_FNAME) != EOF) { + ipfd = open (Memc[str], READ_ONLY, TEXT_FILE) + call rg_lsets (ls, PHOTFILE, Memc[str]) + } + nregions = rg_lrphot (ipfd, ls, 1, rg_lstati (ls, + NREGIONS), NO) + if (nregions <= 0 && interactive == NO) + call error (0, + "The input photometry file is empty.") + if (nregions < rg_lstati (ls, NREGIONS) && interactive == NO) { + call eprintf ("The input photometry file has fewer") + call eprintf (" objects than the reference photoemtry") + call eprintf (" file.\n") + call erract (EA_FATAL) + } + } + + # Open the output image if any. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = EOS + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = EOS + } + call rg_lsets (ls, OUTIMAGE, Memc[image2]) + + # Get the record names. + if (reclist == NULL) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + else if (fntgfnb (reclist, Memc[str], SZ_FNAME) == EOF) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + call rg_lsets (ls, RECORD, Memc[str]) + + # Compute the initial shift. + if (sfd != NULL) { + call rg_lgshift (sfd, ls) + } else { + call rg_lsetr (ls, SXSHIFT, rg_lstatr (ls, XSHIFT)) + call rg_lsetr (ls, SYSHIFT, rg_lstatr (ls, YSHIFT)) + } + + # Compute the scaling factors. + if (interactive == YES) { + stat = rg_liscale (imr, im1, im2, db, dformat, reglist, + rpfd, ipfd, sfd, ls, gd, id) + } else { + stat = rg_lscale (imr, im1, db, dformat, ls) + if (verbose == YES) { + if (rg_lstati(ls,BSALGORITHM) == LS_PHOTOMETRY || + rg_lstati(ls,BZALGORITHM) == LS_PHOTOMETRY) + call rg_lstats (ls, PHOTFILE, Memc[str1], SZ_FNAME) + else + call strcpy (Memc[image1], Memc[str1], SZ_FNAME) + call rg_lstats (ls, REFIMAGE, Memc[str], SZ_LINE) + call printf ( + "Average scale factors from %s to %s are %g %g\n") + call pargstr (Memc[str1]) + call pargstr (Memc[str]) + call pargr (rg_lstatr (ls, TBSCALE)) + call pargr (rg_lstatr (ls, TBZERO)) + } + } + + # Scale the image. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + call printf ( + "\tScaling image %s to image %s ...\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + } + call imseti (im1, IM_CANCEL, YES) + call rg_limscale (im1, im2, rg_lstatr (ls, TBSCALE), + rg_lstatr (ls, TBZERO)) + } + + # Close up the input and output images. + if (im1 != NULL) + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + if (stat == YES) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (stat == YES) + break + } + + # Close up the files and images. + if (imr != NULL) + call imunmap (imr) + + # Close up the lists. + if (list1 != NULL) + call imtclose (list1) + if (listr != NULL) { + if (rg_lstati (ls, BZALGORITHM) == LS_PHOTOMETRY || rg_lstati(ls, + BSALGORITHM) == LS_PHOTOMETRY) + call fntclsb (listr) + else + call imtclose (listr) + } + if (list2 != NULL) + call imtclose (list2) + if (sfd != NULL) + call close (sfd) + if (rpfd != NULL) + call close (rpfd) + if (ipfd != NULL) + call close (ipfd) + if (shiftslist != NULL) + call fntclsb (shiftslist) + if (reglist != NULL) + call fntclsb (reglist) + if (reclist != NULL) + call fntclsb (reclist) + if (dformat == YES) + call dtunmap (db) + else + call close (db) + + # Close up the graphics and image display devices. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + # Free the matching structure. + call rg_lfree (ls) + + call sfree (sp) +end + + +# RG_LGAIN -- Fetch the gain parameter from the image header. + +procedure rg_lgain (im, ls) + +pointer im #I pointer to the input image +pointer ls #I pointer to the intensity matching structure + +int ip +pointer sp, key +real epadu +int ctor() +real imgetr() +errchk imgetr() + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, CCDGAIN, Memc[key], SZ_FNAME) + ip = 1 + if (ctor (Memc[key], ip, epadu) <= 0) { + iferr { + epadu = imgetr (im, Memc[key]) + } then { + epadu = INDEFR + call eprintf ("Warning: Image %s Keyword %s not found.\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[key]) + } + } else + epadu = INDEFR + if (IS_INDEFR(epadu) || epadu <= 0.0) + call rg_lsetr (ls, GAIN, INDEFR) + Else + call rg_lsetr (ls, GAIN, epadu) + + call sfree (sp) +end + + +# LG_LRDNOISE -- Fetch the readout noise from the image header. + +procedure rg_lrdnoise (im, ls) + +pointer im #I pointer to the input image +pointer ls #I pointer to the intensity matching structure + +int ip +pointer sp, key +real rdnoise +int ctor() +real imgetr() +errchk imgetr() + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call rg_lstats (ls, CCDREAD, Memc[key], SZ_FNAME) + ip = 1 + if (ctor (Memc[key], ip, rdnoise) <= 0) { + iferr { + rdnoise = imgetr (im, Memc[key]) + } then { + rdnoise = INDEFR + call eprintf ("Warning: Image %s Keyword %s not found.\n") + call pargstr (IM_HDRFILE(im)) + call pargstr (Memc[key]) + } + } else + rdnoise = INDEFR + if (IS_INDEFR(rdnoise) || rdnoise <= 0.0) + call rg_lsetr (ls, READNOISE, INDEFR) + else + call rg_lsetr (ls, READNOISE, rdnoise) + + call sfree (sp) +end + + +# RG_LGSHIFT -- Read the x and y shifts from a file + +procedure rg_lgshift (fd, ls) + +int fd #I input shifts file descriptor +pointer ls #I pointer to the intensity matching structure + +real xshift, yshift +int fscan(), nscan() + +begin + xshift = 0.0 + yshift = 0.0 + + while (fscan(fd) != EOF) { + call gargr (xshift) + call gargr (yshift) + if (nscan() >= 2) + break + xshift = 0.0 + yshift = 0.0 + } + + call rg_lsetr (ls, SXSHIFT, xshift) + call rg_lsetr (ls, SYSHIFT, yshift) +end + + +# RG_LIMSCALE -- Linearly scale the input image. + +procedure rg_limscale (im1, im2, bscale, bzero) + +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +real bscale #I the bscale value +real bzero #I the bzero value + +int ncols +pointer sp, v1, v2, buf1, buf2 +int imgnlr(), impnlr() + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + ncols = IM_LEN(im1,1) + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + while (imgnlr (im1, buf1, Meml[v1]) != EOF) { + if (impnlr (im2, buf2, Meml[v2]) != EOF) + call altmr (Memr[buf1], Memr[buf2], ncols, bscale, bzero) + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/listmatch/mkpkg b/pkg/images/immatch/src/listmatch/mkpkg new file mode 100644 index 00000000..1d9f42c5 --- /dev/null +++ b/pkg/images/immatch/src/listmatch/mkpkg @@ -0,0 +1,12 @@ +# Make the XYXYMATCH/IMCENTROID tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + + +libpkg.a: + t_imctroid.x + t_xyxymatch.x "../../../lib/xyxymatch.h" + ; diff --git a/pkg/images/immatch/src/listmatch/t_imctroid.x b/pkg/images/immatch/src/listmatch/t_imctroid.x new file mode 100644 index 00000000..157e41ca --- /dev/null +++ b/pkg/images/immatch/src/listmatch/t_imctroid.x @@ -0,0 +1,1016 @@ +include +include +include +include + +define LEN_CP 32 # center structure pointer + +# task parameters +define SMALLBOX Memi[($1)] +define BIGBOX Memi[($1)+1] +define VERBOSE Memi[($1)+2] +define NEGATIVE Memi[($1)+3] +define BACKGROUND Memr[P2R(($1)+4)] +define LO_THRESH Memr[P2R(($1)+5)] +define HI_THRESH Memr[P2R(($1)+6)] +define MAX_TRIES Memi[($1)+7] +define TOL Memi[($1)+8] +define MAX_SHIFT Memr[P2R(($1)+9)] + +# other scalars +define IM Memi[($1)+10] +define BOXSIZE Memi[($1)+11] +define BACK_LOCAL Memr[P2R(($1)+12)] +define LO_LOCAL Memr[P2R(($1)+13)] +define HI_LOCAL Memr[P2R(($1)+14)] +define NIMAGES Memi[($1)+15] +define NCOORDS Memi[($1)+16] + +# expensive, but the indexing isn't done excessively many times +define OFF1D (($1)-1) +define OFF2D ((($2)-1)*NCOORDS($1)+(($3)-1)) + +# vectors and matrices +define XINIT_PT Memi[($1)+20] # need space for NCOORDS of these +define YINIT_PT Memi[($1)+21] +define XINIT Memr[XINIT_PT($1)+OFF1D($2)] +define YINIT Memr[YINIT_PT($1)+OFF1D($2)] + +define XSHIFT_PT Memi[($1)+22] # space for NIMAGES of these +define YSHIFT_PT Memi[($1)+23] +define XSHIFT Memr[XSHIFT_PT($1)+OFF1D($2)] +define YSHIFT Memr[YSHIFT_PT($1)+OFF1D($2)] + +define XSIZE_PT Memi[($1)+24] # space for NIMAGES+1 +define YSIZE_PT Memi[($1)+25] +define XSIZE Memr[XSIZE_PT($1)+OFF1D($2)] +define YSIZE Memr[YSIZE_PT($1)+OFF1D($2)] + +define XCENTER_PT Memi[($1)+26] # space for (NIMAGES+1)*NCOORDS +define YCENTER_PT Memi[($1)+27] +define XCENTER Memr[XCENTER_PT($1)+OFF2D($1,$2,$3)] +define YCENTER Memr[YCENTER_PT($1)+OFF2D($1,$2,$3)] + +define XSIGMA_PT Memi[($1)+28] +define YSIGMA_PT Memi[($1)+29] +define XSIGMA Memr[XSIGMA_PT($1)+OFF2D($1,$2,$3)] +define YSIGMA Memr[YSIGMA_PT($1)+OFF2D($1,$2,$3)] + +define REJECTED_PT Memi[($1)+30] +define REJECTED Memi[REJECTED_PT($1)+OFF2D($1,$2,$3)] + + +# list "template" structure, currently just read the file +define LEN_LP 2 + +define LP_FD Memi[($1)] +define LP_LEN Memi[($1)+1] + +# T_IMCENTROID -- Find the centroids of a list of sources in a list of +# images and compute the average shifts relative to a reference image. + +procedure t_imcentroid() + +pointer imlist, coordlist, shiftlist +pointer img, ref, refer, cp, im, sp +int nimages, ncoords, nshifts, ncentered, i, j +real x, y, junk +bool error_seen, firsttime + +pointer imtopenp(), immap(), ia_openp2r(), ia_init() +int imtlen(), imtgetim(), ia_len(), ia_center(), strmatch() + +errchk imtopenp, immap, imunmap +errchk ia_init, ia_openp2r, ia_len, ia_close, ia_center + +begin + call smark (sp) + call salloc (img, SZ_FNAME, TY_CHAR) + call salloc (refer, SZ_FNAME, TY_CHAR) + + error_seen = false + imlist = NULL + coordlist = NULL + shiftlist = NULL + ref = NULL + cp = NULL + + iferr { + # Flush on new line to avoid eprint output from appear + # in the middle of regular output. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Open the input image list. + imlist = imtopenp ("input") + nimages = imtlen (imlist) + if (nimages <= 0) + call error (1, "No images specified") + + # Get the reference image and check name for whitespace. + call clgstr ("reference", Memc[refer], SZ_FNAME) + if (Memc[refer] != EOS && strmatch (Memc[refer], "^#$") == 0) + iferr (ref = immap (Memc[refer], READ_ONLY, 0)) { + ref = NULL + call error (1, "Reference not found") + } + + # Open the coordinate list. + coordlist = ia_openp2r ("coords") + ncoords = ia_len (coordlist) + if (ncoords <= 0) + call error (1, "No coordinates found") + + # Open the shifts file. + shiftlist = ia_openp2r ("shifts") + nshifts = ia_len (shiftlist) + if (nshifts <= 0) + call ia_close (shiftlist) + else if (nshifts != nimages) + call error (1, "Number of shifts doesn't match images") + + # Initialize the centering structure. + cp = ia_init (shiftlist, nimages, coordlist, ncoords) + + if (ref == NULL) + VERBOSE(cp) = YES + + if (VERBOSE(cp) == YES) { + call printf ("#Coords%16tImage X-center Err") + call printf (" Y-center Err Num\n") + call flush (STDOUT) + } + + # Loop over all the images + ncentered = 0 + for (i=1; imtgetim (imlist, Memc[img], SZ_FNAME) != EOF; i=i+1) { + im = immap (Memc[img], READ_ONLY, 0) + IM(cp) = im + + if (IM_NDIM(im) != 2) { + call eprintf ("%s: ") + call pargstr (Memc[img]) + call error (1, "Image is not 2 dimensional") + } + + XSIZE(cp,i) = real (IM_LEN(im,1)) + YSIZE(cp,i) = real (IM_LEN(im,2)) + + if (nshifts == 0) { + BOXSIZE(cp) = BIGBOX(cp) + if (ia_center (cp, XINIT(cp,1), YINIT(cp,1), x, y, + junk, junk) == ERR) + call error (1, "Problem with coarse centering") + XSHIFT(cp,i) = XINIT(cp,1) - x + YSHIFT(cp,i) = YINIT(cp,1) - y + } + + firsttime = true + do j = 1, ncoords { + x = XINIT(cp,j) - XSHIFT(cp,i) + y = YINIT(cp,j) - YSHIFT(cp,i) + + if (x < 1 || x > XSIZE(cp,i) || y < 1 || y > YSIZE(cp,i)) { + REJECTED(cp,i,j) = YES + next + } + + BOXSIZE(cp) = SMALLBOX(cp) + if (ia_center (cp, x, y, XCENTER(cp,i,j), YCENTER(cp,i,j), + XSIGMA(cp,i,j), YSIGMA(cp,i,j)) == ERR) { + REJECTED(cp,i,j) = YES + next + } + + if (abs (XCENTER(cp,i,j) - x) > MAX_SHIFT(cp)) { + REJECTED(cp,i,j) = YES + next + } + if (abs (YCENTER(cp,i,j) - y) > MAX_SHIFT(cp)) { + REJECTED(cp,i,j) = YES + next + } + + if (firsttime) + firsttime = false + + if (VERBOSE(cp) == YES) { + call printf ( + "%20s %9.3f (%.3f) %9.3f (%.3f) %4d\n") + call pargstr (Memc[img]) + call pargr (XCENTER(cp,i,j)) + call pargr (XSIGMA(cp,i,j)) + call pargr (YCENTER(cp,i,j)) + call pargr (YSIGMA(cp,i,j)) + call pargi (j) + } + } + + if (firsttime) { + call eprintf ("Warning: no sources centered in %s\n") + call pargstr (Memc[img]) + call flush (STDERR) + } else + ncentered = ncentered + 1 + + if (VERBOSE(cp) == YES) { + call printf ("\n") + call flush (STDOUT) + } + + call imunmap (im) + } + + # Measure the reference coordinates if any. + if (ref != NULL) { + IM(cp) = ref + + if (IM_NDIM(ref) != 2) { + call eprintf ("%s: ") + call pargstr (Memc[refer]) + call error (1, "Reference image is not 2 dimensional") + } + + XSIZE(cp,nimages+1) = real (IM_LEN(ref,1)) + YSIZE(cp,nimages+1) = real (IM_LEN(ref,2)) + + firsttime = true + do j = 1, ncoords { + x = XINIT(cp,j) + y = YINIT(cp,j) + + if (x < 1 || x > XSIZE(cp,nimages+1) || + y < 1 || y > YSIZE(cp,nimages+1)) { + REJECTED(cp,nimages+1,j) = YES + next + } + + BOXSIZE(cp) = SMALLBOX(cp) + if (ia_center (cp, x, y, XCENTER(cp,nimages+1,j), + YCENTER(cp,nimages+1,j), XSIGMA(cp,nimages+1,j), + YSIGMA(cp,nimages+1,j)) == ERR) { + REJECTED(cp,nimages+1,j) = YES + next + } + + if (abs (XCENTER(cp,nimages+1,j) - x) > MAX_SHIFT(cp)) { + REJECTED(cp,nimages+1,j) = YES + next + } + if (abs (YCENTER(cp,nimages+1,j) - y ) > MAX_SHIFT(cp)) { + REJECTED(cp,nimages+1,j) = YES + next + } + + if (firsttime) { + if (VERBOSE(cp) == YES) { + call printf ( + "#Refcoords%12tReference X-center Err") + call printf (" Y-center Err Num\n") + } + firsttime = false + } + + if (VERBOSE(cp) == YES) { + call printf ( + "%20s %9.3f (%0.3f) %9.3f (%.3f) %4d\n") + call pargstr (Memc[refer]) + call pargr (XCENTER(cp,nimages+1,j)) + call pargr (XSIGMA(cp,nimages+1,j)) + call pargr (YCENTER(cp,nimages+1,j)) + call pargr (YSIGMA(cp,nimages+1,j)) + call pargi (j) + } + } + + if (firsttime) { + call eprintf ("Warning: no sources centered in reference\n") + call flush (STDERR) + + } else { + if (VERBOSE(cp) == YES) { + call printf ("\n") + call flush (STDOUT) + } + + call imtrew (imlist) + call ia_stats (cp, imlist) + + if (ncentered > 1) + call ia_trim (cp) + } + } + + } then + error_seen = true + + call ia_free (cp) + + if (shiftlist != NULL) + call ia_close (shiftlist) + if (ref != NULL) + call imunmap (ref) + if (coordlist != NULL) + call ia_close (coordlist) + if (imlist != NULL) + call imtclose (imlist) + + call sfree (sp) + + if (error_seen) + call erract (EA_WARN) +end + + +# IA_INIT -- Initialize the centering structure. + +pointer procedure ia_init (shiftlist, nshifts, coordlist, ncoords) + +pointer shiftlist #I shift "template" pointer +int nshifts #I number of shifts in list (or # images) +pointer coordlist #I coordinate "template" pointer +int ncoords #I number of coordinates in list + +pointer cp +int boxsize, i +real x, y + +int clgeti(), btoi(), ia_get2r() +real clgetr() +bool clgetb() + +errchk ia_get2r + +begin + call calloc (cp, LEN_CP, TY_STRUCT) + + boxsize = clgeti ("boxsize") + if (mod (boxsize, 2) == 0) { + boxsize = boxsize + 1 + call eprintf ("Warning: boxsize must be odd, using %d\n") + call pargi (boxsize) + } + SMALLBOX(cp) = (boxsize - 1) / 2 + + if (shiftlist == NULL) { + boxsize = clgeti ("bigbox") + if (mod (boxsize, 2) == 0) { + boxsize = boxsize + 1 + call eprintf ("Warning: bigbox must be odd, using %d\n") + call pargi (boxsize) + } + BIGBOX(cp) = (boxsize - 1) / 2 + } + + NEGATIVE(cp) = btoi (clgetb ("negative")) + BACKGROUND(cp) = clgetr ("background") + + x = clgetr ("lower") + y = clgetr ("upper") + + if (IS_INDEFR(x) || IS_INDEFR(y)) { + LO_THRESH(cp) = x + HI_THRESH(cp) = y + } else { + LO_THRESH(cp) = min (x, y) + HI_THRESH(cp) = max (x, y) + } + + MAX_TRIES(cp) = max (clgeti ("niterate"), 2) + TOL(cp) = abs (clgeti ("tolerance")) + MAX_SHIFT(cp) = clgetr ("maxshift") + if (IS_INDEFR(MAX_SHIFT(cp))) + MAX_SHIFT(cp) = MAX_REAL + else + MAX_SHIFT(cp) = abs (MAX_SHIFT(cp)) + VERBOSE(cp) = btoi (clgetb ("verbose")) + + IM(cp) = NULL + + NIMAGES(cp) = nshifts + NCOORDS(cp) = ncoords + + call malloc (XINIT_PT(cp), ncoords, TY_REAL) + call malloc (YINIT_PT(cp), ncoords, TY_REAL) + call malloc (XSHIFT_PT(cp), nshifts, TY_REAL) + call malloc (YSHIFT_PT(cp), nshifts, TY_REAL) + call malloc (XSIZE_PT(cp), nshifts+1, TY_REAL) + call malloc (YSIZE_PT(cp), nshifts+1, TY_REAL) + call malloc (XCENTER_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (YCENTER_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (XSIGMA_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call malloc (YSIGMA_PT(cp), (nshifts+1)*ncoords, TY_REAL) + call calloc (REJECTED_PT(cp), (nshifts+1)*ncoords, TY_INT) + + for (i=1; ia_get2r (coordlist, x, y) != EOF; i=i+1) { + if (i > ncoords) + call error (1, "problem reading coordinate file") + XINIT(cp,i) = x + YINIT(cp,i) = y + } + + for (i=1; ia_get2r (shiftlist, x, y) != EOF; i=i+1) { + if (i > nshifts) + call error (1, "problem reading shifts file") + XSHIFT(cp,i) = x + YSHIFT(cp,i) = y + } + + return (cp) +end + + +# IA_FREE -- Free the structure pointer. + +procedure ia_free (cp) + +pointer cp #O center structure pointer + +begin + if (cp == NULL) + return + + if (REJECTED_PT(cp) != NULL) + call mfree (REJECTED_PT(cp), TY_INT) + if (XSIGMA_PT(cp) != NULL) + call mfree (XSIGMA_PT(cp), TY_REAL) + if (YSIGMA_PT(cp) != NULL) + call mfree (YSIGMA_PT(cp), TY_REAL) + if (XCENTER_PT(cp) != NULL) + call mfree (XCENTER_PT(cp), TY_REAL) + if (YCENTER_PT(cp) != NULL) + call mfree (YCENTER_PT(cp), TY_REAL) + if (XSIZE_PT(cp) != NULL) + call mfree (XSIZE_PT(cp), TY_REAL) + if (YSIZE_PT(cp) != NULL) + call mfree (YSIZE_PT(cp), TY_REAL) + if (XSHIFT_PT(cp) != NULL) + call mfree (XSHIFT_PT(cp), TY_REAL) + if (YSHIFT_PT(cp) != NULL) + call mfree (YSHIFT_PT(cp), TY_REAL) + if (XINIT_PT(cp) != NULL) + call mfree (XINIT_PT(cp), TY_REAL) + if (YINIT_PT(cp) != NULL) + call mfree (YINIT_PT(cp), TY_REAL) + + call mfree (cp, TY_STRUCT) + cp = NULL # just in case... +end + + +# IA_CENTER -- Compute star center using MPC algorithm. + +int procedure ia_center (cp, xinit, yinit, xcenter, ycenter, xsigma, ysigma) + +pointer cp #I center structure pointer +real xinit, yinit #I initial x and y coordinates +real xcenter, ycenter #O centered x and y coordinates +real xsigma, ysigma #O centering errors + +int x1, x2, y1, y2, nx, ny, try +pointer im, buf, xbuf, ybuf, sp +real xold, yold, xnew, ynew +bool converged + +pointer imgs2r() +real ia_ctr1d() + +errchk imgs2r, ia_threshold, ia_rowsum, ia_colsum, ia_ctr1d + +begin + im = IM(cp) + xold = xinit + yold = yinit + converged = false + + do try = 1, MAX_TRIES(cp) { + x1 = max (nint(xold) - BOXSIZE(cp), 1) + x2 = min (nint(xold) + BOXSIZE(cp), IM_LEN(im,1)) + y1 = max (nint(yold) - BOXSIZE(cp), 1) + y2 = min (nint(yold) + BOXSIZE(cp), IM_LEN(im,2)) + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # inside the loop in case we're near an edge + call smark (sp) + call salloc (xbuf, nx, TY_REAL) + call salloc (ybuf, ny, TY_REAL) + + iferr { + buf = imgs2r (im, x1, x2, y1, y2) + + call ia_threshold (cp, Memr[buf], nx*ny) + call ia_rowsum (cp, Memr[buf], Memr[xbuf], nx, ny) + call ia_colsum (cp, Memr[buf], Memr[ybuf], nx, ny) + + xnew = x1 + ia_ctr1d (Memr[xbuf], nx, xsigma) + ynew = y1 + ia_ctr1d (Memr[ybuf], ny, ysigma) + } then { + call sfree (sp) + call erract (EA_WARN) + return (ERR) + } + + call sfree (sp) + + if (abs (nint(xnew) - nint(xold)) <= TOL(cp) && + abs (nint(ynew) - nint(yold)) <= TOL(cp)) { + + converged = true + break + } + + xold = xnew + yold = ynew + } + + if (converged) { + xcenter = xnew + ycenter = ynew + return (OK) + } else { + call eprintf ("Warning: failed to converge near (%d,%d)\n") + call pargi (nint (xinit)) + call pargi (nint (yinit)) + call flush (STDERR) + return (ERR) + } +end + + +# IA_THRESHOLD -- Find the low and high thresholds for the subraster. + +procedure ia_threshold (cp, raster, npix) + +pointer cp #I center structure pointer +real raster[ARB] #I 2-D subraster +int npix #I size of the (apparently) 1-D subraster + +real lo, hi, junk + +int awvgr() + +errchk alimr, awvgr + +begin + # use the local data min or max for thresholds that are INDEF. + if (IS_INDEFR(LO_THRESH(cp)) || IS_INDEFR(HI_THRESH(cp))) + call alimr (raster, npix, lo, hi) + if (! IS_INDEFR(LO_THRESH(cp))) + lo = LO_THRESH(cp) + if (! IS_INDEFR(HI_THRESH(cp))) + hi = HI_THRESH(cp) + + if (IS_INDEFR(BACKGROUND(cp))) { + if (awvgr (raster, npix, BACK_LOCAL(cp), junk, lo, hi) <= 0) + call error (1, "no pixels between thresholds") + } else + BACK_LOCAL(cp) = BACKGROUND(cp) + + if (NEGATIVE(cp) == YES) { + LO_LOCAL(cp) = lo + HI_LOCAL(cp) = min (hi, BACK_LOCAL(cp)) + } else { + LO_LOCAL(cp) = max (lo, BACK_LOCAL(cp)) + HI_LOCAL(cp) = hi + } +end + + +# IA_ROWSUM -- Sum all rows in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure ia_rowsum (cp, raster, row, nx, ny) + +pointer cp #I center structure pointer +real raster[nx,ny] #I 2-D subraster +real row[ARB] #O 1-D squashed row vector +int nx, ny #I dimensions of the subraster + +int i, j +real lo, hi, back, pix + +begin + call aclrr (row, nx) + + back = BACK_LOCAL(cp) + lo = LO_LOCAL(cp) + hi = HI_LOCAL(cp) + + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + row[i] = row[i] + pix - back + } + + if (NEGATIVE(cp) == YES) + call adivkr (row, -real(ny), row, nx) + else + call adivkr (row, real(ny), row, nx) + + # recycle lo (and hi) + call alimr (row, nx, lo, hi) + if (lo < 0.) + call error (1, "Negative value in marginal row\n") +end + + +# IA_COLSUM -- Sum all columns in a raster, subject to the thresholds, the +# background, and other parameters. + +procedure ia_colsum (cp, raster, col, nx, ny) + +pointer cp #I center structure pointer +real raster[nx,ny] #I 2-D subraster +real col[ARB] #O 1-D squashed col vector +int nx, ny #I dimensions of the subraster + +int i, j +real lo, hi, back, pix + +begin + call aclrr (col, ny) + + back = BACK_LOCAL(cp) + lo = LO_LOCAL(cp) + hi = HI_LOCAL(cp) + + do j = 1, ny + do i = 1, nx { + pix = raster[i,j] + if (lo <= pix && pix <= hi) + col[j] = col[j] + pix - back + } + + if (NEGATIVE(cp) == YES) + call adivkr (col, -real(nx), col, ny) + else + call adivkr (col, real(nx), col, ny) + + # recycle lo (and hi) + call alimr (col, ny, lo, hi) + if (lo < 0.) + call error (1, "Negative value in marginal column\n") +end + + +# IA_CNTR1D -- Compute the the first moment. + +real procedure ia_ctr1d (a, npix, err) + +real a[ARB] #I marginal vector +int npix #I size of the vector +real err #O error in the centroid + +real centroid, pix, sumi, sumix, sumix2 +int i + +bool fp_equalr() + +begin + sumi = 0. + sumix = 0. + sumix2 = 0. + + do i = 1, npix { + pix = a[i] + sumi = sumi + pix + sumix = sumix + pix * (i-1) + sumix2 = sumix2 + pix * (i-1) ** 2 + } + + if (fp_equalr (sumi, 0.)) + call error (1, "zero marginal vector") + + else { + centroid = sumix / sumi + err = sumix2 / sumi - centroid ** 2 + if (err > 0.) + err = sqrt (err / sumi) + else + err = 0. + } + + return (centroid) +end + + +# IA_OPENP2R -- Open a list file from which two real values per line +# are expected. + +pointer procedure ia_openp2r (param) + +char param[ARB] #I parameter name + +int fd, length +pointer lp, fname, sp +real x1, x2 + +int open(), fscan(), nscan(), strmatch() + +errchk open + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call clgstr (param, Memc[fname], SZ_FNAME) + + # Whitespace in the name ? + if (strmatch (Memc[fname], "^#$") != 0) { + call sfree (sp) + return (NULL) + } + + # This should be replaced by some template mechanism. + ifnoerr (fd = open (Memc[fname], READ_ONLY, TEXT_FILE)) { + length = 0 + while (fscan (fd) != EOF) { + call gargr (x1) + call gargr (x2) + + switch (nscan()) { + case 2: + length = length + 1 + case 1: + call error (1, "Reading file, only one value on line") + default: + # read another line + } + } + call seek (fd, BOF) + } else { + fd = NULL + length = 0 + } + + call sfree (sp) + + call malloc (lp, LEN_LP, TY_STRUCT) + LP_FD(lp) = fd + LP_LEN(lp) = length + + return (lp) +end + + +# IA_LEN -- Return the length of a list file, given its descriptor. + +int procedure ia_len (lp) + +pointer lp #I list file descriptor + +begin + if (lp == NULL) + return (0) + else + return (LP_LEN(lp)) +end + + +# IA_GET2R -- Get two real numbers from the next line of the list file. + +int procedure ia_get2r (lp, x1, x2) + +pointer lp #I list file descriptor +real x1, x2 #O values to read + +int fscan(), nscan() + +begin + if (lp == NULL) { + x1 = INDEFR + x2 = INDEFR + return (EOF) + } + + while (fscan (LP_FD(lp)) != EOF) { + call gargr (x1) + call gargr (x2) + + switch (nscan()) { + case 2: + return (2) + case 1: + call error (1, "only one value on line") + default: + # read another line + } + } + + x1 = INDEFR + x2 = INDEFR + return (EOF) +end + + +# IA_CLOSE -- Close a list file descriptor. + +procedure ia_close (lp) + +pointer lp #I list file descriptor + +errchk close + +begin + if (lp == NULL) + return + + if (LP_FD(lp) != NULL) + call close (LP_FD(lp)) + + call mfree (lp, TY_STRUCT) + lp = NULL # just in case... +end + + +# IA_STATS -- Compute the x and y shifts. + +procedure ia_stats (cp, imlist) + +pointer cp #I center structure pointer +pointer imlist #I image template (for labeling) + +real xshift, yshift, xsum, ysum +real xsum2, ysum2, xsig2, ysig2 +real xvar, yvar, xerr, yerr, xprop, yprop +int nim, ncoo, nsources, i, j +pointer img, sp +bool firsttime + +int imtgetim() + +begin + call smark (sp) + call salloc (img, SZ_FNAME, TY_CHAR) + + nim = NIMAGES(cp) + ncoo = NCOORDS(cp) + + firsttime = true + for (i=1; imtgetim (imlist, Memc[img], SZ_FNAME) != EOF; i=i+1) { + xsum = 0. + ysum = 0. + xsum2 = 0. + ysum2 = 0. + xsig2 = 0. + ysig2 = 0. + nsources = 0 + + do j = 1, ncoo { + if (REJECTED(cp,i,j) == YES || REJECTED(cp,nim+1,j) == YES) + next + + xshift = XCENTER(cp,nim+1,j) - XCENTER(cp,i,j) + yshift = YCENTER(cp,nim+1,j) - YCENTER(cp,i,j) + + xsum = xsum + xshift + ysum = ysum + yshift + + # internal errors + xsum2 = xsum2 + xshift*xshift + ysum2 = ysum2 + yshift*yshift + + xsig2 = xsig2 + XSIGMA(cp,nim+1,j)**2 + XSIGMA(cp,i,j)**2 + ysig2 = ysig2 + YSIGMA(cp,nim+1,j)**2 + YSIGMA(cp,i,j)**2 + + nsources = nsources + 1 + } + + if (nsources == 0) { + XSHIFT(cp,i) = INDEFR + YSHIFT(cp,i) = INDEFR + next + } + + XSHIFT(cp,i) = xsum / nsources + YSHIFT(cp,i) = ysum / nsources + + if (nsources > 1) { + xvar = (nsources*xsum2 - xsum*xsum) / (nsources * (nsources-1)) + yvar = (nsources*ysum2 - ysum*ysum) / (nsources * (nsources-1)) + xerr = sqrt (max (xvar/nsources, 0.)) + yerr = sqrt (max (yvar/nsources, 0.)) + } else { + xerr = INDEFR + yerr = INDEFR + } + + xprop = sqrt (max (xsig2, 0.)) / nsources + yprop = sqrt (max (ysig2, 0.)) / nsources + + if (firsttime) { + call printf ("#Shifts%16tImage X-shift Err ") + call printf ("Y-shift Err N Internal\n") + firsttime = false + } + + call printf ( + "%20s %8.3f (%.3f) %8.3f (%.3f) %4d (%.3f,%.3f)\n") + call pargstr (Memc[img]) + call pargr (XSHIFT(cp,i)) + call pargr (xprop) + call pargr (YSHIFT(cp,i)) + call pargr (yprop) + call pargi (nsources) + call pargr (xerr) + call pargr (yerr) + } + + call flush (STDOUT) + call sfree (sp) +end + + +# IA_TRIM -- Compute the trim section. + +procedure ia_trim (cp) + +pointer cp #I center structure pointer + +real xlo, xhi, ylo, yhi, xmin, ymin +int ixlo, ixhi, iylo, iyhi, ixlonew, ixhinew, iylonew, iyhinew, i +int vxlo, vxhi, vylo, vyhi # vignetted versions +bool firsttime + +begin + firsttime = true + do i = 1, NIMAGES(cp) { + + if (IS_INDEFR(XSHIFT(cp,i)) || IS_INDEFR(YSHIFT(cp,i))) + next + + # Compute limits. + xlo = 1. + XSHIFT(cp,i) + ylo = 1. + YSHIFT(cp,i) + xhi = XSIZE(cp,i) + XSHIFT(cp,i) + yhi = YSIZE(cp,i) + YSHIFT(cp,i) + + ixlonew = int (xlo) + if (xlo > ixlonew) # round up + ixlonew = ixlonew + 1 + + ixhinew = int (xhi) + if (xhi < ixhinew) # round down + ixhinew = ixhinew - 1 + + iylonew = int (ylo) # round up + if (ylo > iylonew) + iylonew = iylonew + 1 + + iyhinew = int (yhi) # round down + if (yhi < iyhinew) + iyhinew = iyhinew - 1 + + if (firsttime) { + ixlo = ixlonew + ixhi = ixhinew + iylo = iylonew + iyhi = iyhinew + + xmin = XSIZE(cp,i) + ymin = YSIZE(cp,i) + + firsttime = false + } else { + ixlo = max (ixlo, ixlonew) + ixhi = min (ixhi, ixhinew) + iylo = max (iylo, iylonew) + iyhi = min (iyhi, iyhinew) + + xmin = min (XSIZE(cp,i), xmin) + ymin = min (YSIZE(cp,i), ymin) + } + } + + # Don't bother to complain. + if (firsttime) + return + + call printf ("\n") + + # Vignetting is possible downstream since imshift and other tasks + # preserve the size of the input image. + + vxlo = max (1, min (ixlo, int(xmin))) + vxhi = max (1, min (ixhi, int(xmin))) + vylo = max (1, min (iylo, int(ymin))) + vyhi = max (1, min (iyhi, int(ymin))) + if (vxlo != ixlo || vxhi != ixhi || vylo != iylo || vyhi != iyhi) { + call eprintf ("#Vignette_Section = [%d:%d,%d:%d]\n") + call pargi (vxlo) + call pargi (vxhi) + call pargi (vylo) + call pargi (vyhi) + } + + # Output the trim section. + call printf ("#Trim_Section = [%d:%d,%d:%d]\n") + call pargi (ixlo) + call pargi (ixhi) + call pargi (iylo) + call pargi (iyhi) + + call flush (STDOUT) +end diff --git a/pkg/images/immatch/src/listmatch/t_xyxymatch.x b/pkg/images/immatch/src/listmatch/t_xyxymatch.x new file mode 100644 index 00000000..1c8a16c5 --- /dev/null +++ b/pkg/images/immatch/src/listmatch/t_xyxymatch.x @@ -0,0 +1,406 @@ +include +include "../../../lib/xyxymatch.h" + +# T_XYXYMATCH -- This task computes the intersection of a set of +# of coordinate lists with a reference coordinate list. The output is +# the set of objects common to both lists. In its simplest form LINXYMATCH +# uses a matching tolerance to generate the common list. Alternatively +# XYXYMATCH can use coordinate transformation information derived from the +# positions of one to three stars common to both lists, a sorting algorithm, +# and a matching tolerance to generate the common list. A more sophisticated +# pattern matching algorithm is also available which requires no coordinate +# transformation input from the user but is expensive computationally. + +procedure t_xyxymatch() + +bool interactive, verbose +int ilist, rlist, olist, rfd, rpfd, ifd, ofd +int xcol, ycol, xrefcol, yrefcol, maxntriangles, nreftie, nintie +int ntie, match, nrefstars, nliststars, ninter, nrmaxtri, nreftri +int ninmaxtri, nintri, ntrefstars, ntliststars, nreject +pointer sp, inname, refname, outname, refpoints, str, xreftie, yreftie +pointer xintie, yintie, coeff, xref, yref, rlineno, rsindex, reftri, reftrirat +pointer xlist, ylist, listindex, ilineno, xtrans, ytrans, intri, intrirat +pointer xformat, yformat +real tolerance, separation, xin, yin, xmag, ymag, xrot, yrot, xout, yout +real ratio + +bool clgetb() +int clpopnu(), clplen(), clgeti(), clgfil(), open(), clgwrd() +int rg_getreftie(), rg_lincoeff(), fstati(), rg_rdxyi(), rg_sort() +int rg_intersection(), rg_factorial(), rg_triangle(), rg_match() +int rg_mlincoeff() +real clgetr() + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (inname, SZ_FNAME, TY_CHAR) + call salloc (refname, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (refpoints, SZ_FNAME, TY_CHAR) + call salloc (xreftie, MAX_NTIE, TY_REAL) + call salloc (yreftie, MAX_NTIE, TY_REAL) + call salloc (xintie, MAX_NTIE, TY_REAL) + call salloc (yintie, MAX_NTIE, TY_REAL) + call salloc (coeff, MAX_NCOEFF, TY_REAL) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input, output, and reference lists. + ilist = clpopnu ("input") + rlist = clpopnu ("reference") + olist = clpopnu ("output") + tolerance = clgetr ("tolerance") + call clgstr ("refpoints", Memc[refpoints], SZ_FNAME) + + # Check the input and output file lengths. + if (clplen (rlist) > 1 && clplen (rlist) != clplen (ilist)) + call error (0, + "The number of input and reference lists are not the same") + if (clplen (ilist) != clplen (olist)) + call error (0, + "The number of input and output lists are not the same") + + xcol = clgeti ("xcolumn") + ycol = clgeti ("ycolumn") + xrefcol = clgeti ("xrcolumn") + yrefcol = clgeti ("yrcolumn") + + # Get the matching parameters. + match = clgwrd ("matching", Memc[str], SZ_LINE, RG_MATCHSTR) + xin = clgetr ("xin") + if (IS_INDEFR(xin)) + xin = 0.0 + yin = clgetr ("yin") + if (IS_INDEFR(yin)) + yin = 0.0 + xmag = clgetr ("xmag") + if (IS_INDEFR(xmag)) + xmag = 1.0 + ymag = clgetr ("ymag") + if (IS_INDEFR(ymag)) + ymag = 1.0 + xrot = clgetr ("xrotation") + if (IS_INDEFR(xrot)) + xrot = 0.0 + yrot = clgetr ("yrotation") + if (IS_INDEFR(yrot)) + yrot = 0.0 + xout = clgetr ("xref") + if (IS_INDEFR(xout)) + xout = 0.0 + yout = clgetr ("yref") + if (IS_INDEFR(yout)) + yout = 0.0 + + # Get the algorithm parameters. + separation = clgetr ("separation") + maxntriangles = clgeti ("nmatch") + ratio = clgetr ("ratio") + nreject = clgeti ("nreject") + + # Get the output formatting parameters. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + + interactive = clgetb ("interactive") + verbose = clgetb ("verbose") + + # Open the reference list file if any. + rfd = NULL + if (Memc[refpoints] == EOS) + rpfd = NULL + else + rpfd = open (Memc[refpoints], READ_ONLY, TEXT_FILE) + + # Initialize. + xref = NULL + yref = NULL + rsindex = NULL + rlineno = NULL + + # Loop over the input lists. + while (clgfil (ilist, Memc[inname], SZ_FNAME) != EOF && + clgfil (olist, Memc[outname], SZ_FNAME) != EOF) { + + # Open the input list. + ifd = open (Memc[inname], READ_ONLY, TEXT_FILE) + + # Open the output list. + ofd = open (Memc[outname], NEW_FILE, TEXT_FILE) + + # Open the reference list and get the coordinates. + while (clgfil (rlist, Memc[refname], SZ_FNAME) != EOF) { + + # Open the reference file. + if (rfd != NULL) + call close (rfd) + rfd = open (Memc[refname], READ_ONLY, TEXT_FILE) + + # Fetch the reference tie points. + if (interactive || rpfd != NULL) + nreftie = rg_getreftie (rpfd, Memr[xreftie], + Memr[yreftie], 3, RG_REFFILE, interactive) + else + nreftie = 0 + + # Read the reference data. + if (xref != NULL) + call mfree (xref, TY_REAL) + if (yref != NULL) + call mfree (yref, TY_REAL) + if (rlineno != NULL) + call mfree (rlineno, TY_INT) + if (rsindex != NULL) + call mfree (rsindex, TY_INT) + ntrefstars = rg_rdxyi (rfd, xref, yref, rlineno, xrefcol, + yrefcol) + call malloc (rsindex, ntrefstars, TY_INT) + + # Prepare the reference list for the merge algorithm. If a tie + # point matching algorithm is selected, sort the list in the + # y and then the x coordinate and remove coincident points. + # If the pattern matching algorithm is used then construct the + # triangles used for matching and sort them in order of + # increasing ratio. + + nrefstars = rg_sort (Memr[xref], Memr[yref], Memi[rsindex], + ntrefstars, separation, YES, YES) + if (match != RG_TRIANGLES) { + reftri = NULL + reftrirat = NULL + nreftri = nrefstars + } else if (nrefstars > 2) { + nrmaxtri = rg_factorial (min (nrefstars, maxntriangles), 3) + call calloc (reftri, SZ_TRIINDEX * nrmaxtri, TY_INT) + call calloc (reftrirat, SZ_TRIPAR * nrmaxtri, TY_REAL) + nreftri = rg_triangle (Memr[xref], Memr[yref], + Memi[rsindex], nrefstars, Memi[reftri], + Memr[reftrirat], nrmaxtri, maxntriangles, + tolerance, ratio) + } else { + nreftri = 0 + reftri = NULL + reftrirat = NULL + } + + break + } + + # Fetch the input tie points and compute the coefficients. + if (interactive || rpfd != NULL) + nintie = rg_getreftie (rpfd, Memr[xintie], + Memr[yintie], nreftie, RG_INFILE, interactive) + else + nintie = 0 + ntie = min (nreftie, nintie) + if (ntie <= 0) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + else if (rg_lincoeff (Memr[xreftie], Memr[yreftie], + Memr[xintie], Memr[yintie], ntie, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + + # Print the header. + if (verbose) { + call printf ("\nInput: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call printf ("Number of tie points: %d\n") + call pargi (ntie) + } + call fprintf (ofd, "\n# Input: %s Reference: %s ") + call pargstr (Memc[inname]) + call pargstr (Memc[refname]) + call fprintf (ofd, "Number of tie points: %d\n") + call pargi (ntie) + + # Print the coordinate transformation information. + if (verbose) + call rg_plincoeff ("xref", "yref", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + call rg_wlincoeff (ofd, "xref", "yref", Memr[xreftie], + Memr[yreftie], Memr[xintie], Memr[yintie], ntie, + Memr[coeff], MAX_NCOEFF) + + # Read in the input list. + xtrans = NULL + ytrans = NULL + listindex = NULL + ntliststars = rg_rdxyi (ifd, xlist, ylist, ilineno, xcol, ycol) + + # Compute the intersection of the two lists using either an + # algorithm depending on common tie points or on a more + # sophisticated pattern matching algorithm. + + if (ntrefstars <= 0) { + if (verbose) + call printf (" The reference coordinate list is empty\n") + ninter = 0 + } else if (ntliststars <= 0) { + if (verbose) + call printf (" The input coordinate list is empty\n") + ninter = 0 + } else if (nreftri <= 0) { + if (verbose) + call printf ( + " No valid reference triangles can be defined\n") + } else { + call malloc (xtrans, ntliststars, TY_REAL) + call malloc (ytrans, ntliststars, TY_REAL) + call malloc (listindex, ntliststars, TY_INT) + call rg_compute (Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], ntliststars, Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, YES, YES) + if (match != RG_TRIANGLES) { + intri = NULL + intrirat = NULL + nintri = nliststars + call rg_pxycolumns (ofd) + ninter = rg_intersection (ofd, Memr[xref], Memr[yref], + Memi[rsindex], Memi[rlineno], nrefstars, Memr[xlist], + Memr[ylist], Memr[xtrans], Memr[ytrans], + Memi[listindex], Memi[ilineno], nliststars, tolerance, + Memc[xformat], Memc[yformat]) + } else if (nliststars > 2) { + ninmaxtri = rg_factorial (min (max(nliststars,nrefstars), + maxntriangles), 3) + call calloc (intri, SZ_TRIINDEX * ninmaxtri, TY_INT) + call calloc (intrirat, SZ_TRIPAR * ninmaxtri, TY_REAL) + nintri = rg_triangle (Memr[xtrans], Memr[ytrans], + Memi[listindex], nliststars, Memi[intri], + Memr[intrirat], ninmaxtri, maxntriangles, + tolerance, ratio) + if (nintri <= 0) { + if (verbose) + call printf ( + " No valid input triangles can be defined\n") + } else { + ninter = rg_match (Memr[xref], Memr[yref], nrefstars, + Memr[xtrans], Memr[ytrans], nliststars, + Memi[reftri], Memr[reftrirat], nreftri, nrmaxtri, + ntrefstars, Memi[intri], Memr[intrirat], nintri, + ninmaxtri, ntliststars, tolerance, tolerance, + ratio, nreject) + } + if (nrefstars <= maxntriangles && nliststars <= + maxntriangles) { + call rg_pxycolumns (ofd) + call rg_mwrite (ofd, Memr[xref], Memr[yref], + Memi[rlineno], Memr[xlist], Memr[ylist], + Memi[ilineno], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memc[xformat], + Memc[yformat]) + } else { + if (rg_mlincoeff (Memr[xref], Memr[yref], Memr[xlist], + Memr[ylist], Memi[reftri], nrmaxtri, + Memi[intri], ninmaxtri, ninter, Memr[coeff], + MAX_NCOEFF) == ERR) + call rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, + xout, yout, Memr[coeff], MAX_NCOEFF) + call rg_compute (Memr[xlist], Memr[ylist], + Memr[xtrans], Memr[ytrans], ntliststars, + Memr[coeff], MAX_NCOEFF) + nliststars = rg_sort (Memr[xtrans], Memr[ytrans], + Memi[listindex], ntliststars, separation, + YES, YES) + if (verbose) + call rg_pmlincoeff ("xref", "yref", Memr[coeff], + MAX_NCOEFF) + call rg_wmlincoeff (ofd, "xref", "yref", Memr[coeff], + MAX_NCOEFF) + call rg_pxycolumns (ofd) + ninter = rg_intersection (ofd, Memr[xref], Memr[yref], + Memi[rsindex], Memi[rlineno], nrefstars, + Memr[xlist], Memr[ylist], Memr[xtrans], + Memr[ytrans], Memi[listindex], Memi[ilineno], + nliststars, tolerance, Memc[xformat], Memc[yformat]) + } + } else { + if (verbose) + call printf ( + "\tThe input coordinate list has < 3 stars\n") + intri = NULL + intrirat = NULL + nintri = 0 + ninter = 0 + } + } + + # Print out the number of stars matched in the two lists. + if (verbose) { + call printf ("%d reference coordinates matched\n") + call pargi (ninter) + } + + # Free space used by input list. + call mfree (xlist, TY_REAL) + call mfree (ylist, TY_REAL) + call mfree (ilineno, TY_INT) + call mfree (listindex, TY_INT) + if (xtrans != NULL) + call mfree (xtrans, TY_REAL) + if (ytrans != NULL) + call mfree (ytrans, TY_REAL) + if (intri != NULL) + call mfree (intri, TY_INT) + if (intrirat != NULL) + call mfree (intrirat, TY_REAL) + + # Close the input and output lists. + call close (ifd) + call close (ofd) + } + + # Release the memory used to store the reference list. + call mfree (xref, TY_REAL) + call mfree (yref, TY_REAL) + call mfree (rlineno, TY_INT) + call mfree (rsindex, TY_INT) + if (reftri != NULL) + call mfree (reftri, TY_INT) + if (reftrirat != NULL) + call mfree (reftrirat, TY_REAL) + + # Close the reference file. + if (rfd != NULL) + call close (rfd) + + # Close the reference points file. + if (rpfd != NULL) + call close (rpfd) + + # Close the file lists. + call clpcls (ilist) + call clpcls (rlist) + call clpcls (olist) + + call sfree (sp) +end + + +# RG_PXYCOLUMNS -- Print the column descriptions in the output file. + +procedure rg_pxycolumns (ofd) + +int ofd #I the output file descriptor + +begin + call fprintf (ofd, "# Column definitions\n") + call fprintf (ofd, "# Column 1: X reference coordinate\n") + call fprintf (ofd, "# Column 2: Y reference coordinate\n") + call fprintf (ofd, "# Column 3: X input coordinate\n") + call fprintf (ofd, "# Column 4: Y input coordinate\n") + call fprintf (ofd, "# Column 5: Reference line number\n") + call fprintf (ofd, "# Column 6: Input line number\n") + call fprintf (ofd, "\n") +end diff --git a/pkg/images/immatch/src/mkpkg b/pkg/images/immatch/src/mkpkg new file mode 100644 index 00000000..ec8accec --- /dev/null +++ b/pkg/images/immatch/src/mkpkg @@ -0,0 +1,11 @@ +# Library for the IMMATCH Package. + +libpkg.a: + @geometry + @imcombine + @linmatch + @listmatch + @psfmatch + @wcsmatch + @xregister + ; diff --git a/pkg/images/immatch/src/psfmatch/mkpkg b/pkg/images/immatch/src/psfmatch/mkpkg new file mode 100644 index 00000000..da3951dc --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/mkpkg @@ -0,0 +1,21 @@ +# Make the PSFMATCH task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgpbckgrd.x "psfmatch.h" + rgpcolon.x "psfmatch.h" + rgpconvolve.x + rgpisfm.x "psfmatch.h" + rgpfft.x + rgpfilter.x + rgppars.x "psfmatch.h" + rgpregions.x "psfmatch.h" + rgpsfm.x "psfmatch.h" + rgpshow.x "psfmatch.h" + rgptools.x "psfmatch.h" + t_psfmatch.x "psfmatch.h" + ; diff --git a/pkg/images/immatch/src/psfmatch/psfmatch.h b/pkg/images/immatch/src/psfmatch/psfmatch.h new file mode 100644 index 00000000..c6b7d563 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/psfmatch.h @@ -0,0 +1,274 @@ +# Header file for PSFMATCH + +define LEN_PSFSTRUCT (45 + 12 * SZ_FNAME + 12) + +# Define the psf fitting structure + +define PM_RC1 Memi[$1] # pointer to first column of region +define PM_RC2 Memi[$1+1] # pointer to last column of region +define PM_RL1 Memi[$1+2] # pointer to first line of region +define PM_RL2 Memi[$1+3] # pointer to last line of region +define PM_RZERO Memi[$1+4] # pointer to zero point of ref regions +define PM_RXSLOPE Memi[$1+5] # pointer to x slopes of ref regions +define PM_RYSLOPE Memi[$1+6] # pointer to y slopes of ref regions +define PM_NREGIONS Memi[$1+7] # total number of regions +define PM_CNREGION Memi[$1+8] # the current region + +define PM_CENTER Memi[$1+9] # the the psf objects +define PM_BACKGRD Memi[$1+10] # type of background subtraction +define PM_BVALUER Memr[P2R($1+11)] # reference background value +define PM_BVALUE Memr[P2R($1+12)] # image background value +define PM_LOREJECT Memr[P2R($1+13)] # low side rejection +define PM_HIREJECT Memr[P2R($1+14)] # high side rejection +define PM_APODIZE Memr[P2R($1+15)] # fraction of region to be apodized + +define PM_CONVOLUTION Memi[$1+16] # the convolution type +define PM_DNX Memi[$1+17] # x dimension of kernel +define PM_DNY Memi[$1+18] # y dimension of kernel +define PM_PNX Memi[$1+19] # x dimension of user kernel +define PM_PNY Memi[$1+20] # y dimension of user kernel +define PM_KNX Memi[$1+21] # x size of kernel +define PM_KNY Memi[$1+22] # x size of kernel + +define PM_POWER Memi[$1+23] # save power spectrum of kernel ? + +define PM_UFLUXRATIO Memr[P2R($1+24)] # the user ref / input flux ratio +define PM_FLUXRATIO Memr[P2R($1+25)] # ref / input flux ratio +define PM_FILTER Memi[$1+26] # background filtering +define PM_SXINNER Memr[P2R($1+27)] # inner radius for cosine bell +define PM_SXOUTER Memr[P2R($1+28)] # outer radius for cosine bell +define PM_SYINNER Memr[P2R($1+29)] # inner radius for cosine bell +define PM_SYOUTER Memr[P2R($1+30)] # outer radius for cosine bell +define PM_RADSYM Memi[$1+31] # radial symmetry in convolution +define PM_THRESHOLD Memr[P2R($1+32)] # threshold in divisor for model + +define PM_NORMFACTOR Memr[P2R($1+34)] # the normalization factor + +#define PM_PRATIO Memr[P2R($1+24)] # power ration threshold +#define PM_XSHIFTS Memi[$1+26] # pointer to x shifts +#define PM_YSHIFTS Memi[$1+27] # pointer to y shifts + +define PM_REFFFT Memi[$1+35] # pointer to reference fft +define PM_IMFFT Memi[$1+36] # pointer to image fft +define PM_FFT Memi[$1+37] # pointer to unfiltered fft +define PM_CONV Memi[$1+38] # pointer to kernel +define PM_ASFFT Memi[$1+39] # pointer to power spectrum +define PM_NXFFT Memi[$1+40] # x dimension of FFT +define PM_NYFFT Memi[$1+41] # y dimension of FFT + +define PM_BSTRING Memc[P2C($1+42)] # background string +define PM_CSTRING Memc[P2C($1+42+SZ_FNAME+1)] # convolution string +define PM_FSTRING Memc[P2C($1+42+2*SZ_FNAME+2)] # convolution string + +define PM_IMAGE Memc[P2C($1+42+4*SZ_FNAME+4)] # input image +define PM_REFIMAGE Memc[P2C($1+42+5*SZ_FNAME+5)] # reference image +define PM_PSFDATA Memc[P2C($1+42+6*SZ_FNAME+6)] # psf data +define PM_PSFIMAGE Memc[P2C($1+42+7*SZ_FNAME+7)] # psf image if any +define PM_OBJLIST Memc[P2C($1+42+8*SZ_FNAME+8)] # object list if any +define PM_KERNEL Memc[P2C($1+42+9*SZ_FNAME+9)] # kernel image +define PM_OUTIMAGE Memc[P2C($1+42+10*SZ_FNAME+10)] # output convolved image + +# Define the paramerter ids + +define RC1 1 +define RC2 2 +define RL1 3 +define RL2 4 +define RZERO 5 +define RXSLOPE 6 +define RYSLOPE 7 +define NREGIONS 8 +define CNREGION 9 + +define CENTER 10 +define BACKGRD 11 +define BVALUER 12 +define BVALUE 13 +define LOREJECT 15 +define HIREJECT 16 +define APODIZE 17 + +define CONVOLUTION 18 +define DNX 19 +define DNY 20 +define PNX 21 +define PNY 22 +define KNX 23 +define KNY 24 +define POWER 25 + +#define XSHIFTS 20 +#define YSHIFTS 21 + +define REFFFT 26 +define IMFFT 27 +define FFT 28 +define CONV 29 +define ASFFT 30 +define NXFFT 31 +define NYFFT 32 + +define UFLUXRATIO 33 +define FLUXRATIO 34 +define FILTER 35 +define SXINNER 36 +define SXOUTER 37 +define SYINNER 38 +define SYOUTER 39 +define RADSYM 40 +define THRESHOLD 41 + +define NORMFACTOR 43 + +#define PRATIO 34 + +define BSTRING 44 +define CSTRING 45 +define FSTRING 46 + +define REFIMAGE 48 +define IMAGE 49 +define PSFDATA 50 +define PSFIMAGE 51 +define OBJLIST 52 +define KERNEL 53 +define OUTIMAGE 54 + +# Define the default parameter values + +define DEF_CENTER YES +define DEF_BACKGRD PM_BMEDIAN +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR + +define DEF_CONVOLUTION PM_CONIMAGE +define DEF_DNX 63 +define DEF_DNY 63 +define DEF_PNX 31 +define DEF_PNY 31 +define DEF_POWER NO + +define DEF_FILTER PM_FREPLACE +define DEF_SXINNER INDEFR +define DEF_SXOUTER INDEFR +define DEF_SYINNER INDEFR +define DEF_SYOUTER INDEFR +define DEF_RADSYM NO +define DEF_THRESHOLD 0.0 + +#define DEF_PRATIO 0.0 + +define DEF_NORMFACTOR 1.0 +define DEF_UFLUXRATIO INDEFR + +# Define the background fitting techniques + +define PM_BNONE 1 +define PM_BMEAN 2 +define PM_BMEDIAN 3 +define PM_BSLOPE 4 +define PM_BNUMBER 5 + +define PM_BTYPES "|none|mean|median|plane|" + +# Define the convolution computation options + +define PM_CONIMAGE 1 +define PM_CONPSF 2 +define PM_CONKERNEL 3 + +define PM_CTYPES "|image|psf|kernel|" + +# Define the filtering options + +define PM_FNONE 1 +define PM_FCOSBELL 2 +define PM_FREPLACE 3 +define PM_FMODEL 4 + +define PM_FTYPES "|none|cosbell|replace|model|" + +# Define the normalization options + +define PM_UNIT 1 +define PM_RATIO 2 +define PM_NUMBER 3 + +define PM_NTYPES "|unit|ratio|" + +# Miscellaneous + +define MAX_NREGIONS 100 + +# Commands + +define PMCMDS "|input|reference|psfdata|psfimage|kernel|output|dnx|dny|\ +pnx|pny|center|background|loreject|hireject|apodize|convolution|fluxratio|\ +filter|sx1|sx2|sy1|sy2|radsym|threshold|normfactor|show|mark|" + +define PMCMD_IMAGE 1 +define PMCMD_REFIMAGE 2 +define PMCMD_PSFDATA 3 +define PMCMD_PSFIMAGE 4 +define PMCMD_KERNEL 5 +define PMCMD_OUTIMAGE 6 + +define PMCMD_DNX 7 +define PMCMD_DNY 8 +define PMCMD_PNX 9 +define PMCMD_PNY 10 + +define PMCMD_CENTER 11 +define PMCMD_BACKGRD 12 +define PMCMD_LOREJECT 13 +define PMCMD_HIREJECT 14 +define PMCMD_APODIZE 15 + +define PMCMD_CONVOLUTION 16 +define PMCMD_UFLUXRATIO 17 +define PMCMD_FILTER 18 +define PMCMD_SXINNER 19 +define PMCMD_SXOUTER 20 +define PMCMD_SYINNER 21 +define PMCMD_SYOUTER 22 +define PMCMD_RADSYM 23 +define PMCMD_THRESHOLD 24 + +define PMCMD_NORMFACTOR 25 + +define PMCMD_SHOW 26 +define PMCMD_MARK 27 + +# Keywords + +define KY_IMAGE "input" +define KY_REFIMAGE "reference" +define KY_PSFDATA "psfdata" +define KY_PSFIMAGE "psfimage" +define KY_KERNEL "kernel" +define KY_OUTIMAGE "output" + +define KY_DNX "dnx" +define KY_DNY "dny" +define KY_PNX "pnx" +define KY_PNY "pny" + +define KY_CENTER "center" +define KY_BACKGRD "background" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_APODIZE "apodize" + +define KY_CONVOLUTION "convolution" + +define KY_UFLUXRATIO "fluxratio" +define KY_FILTER "filter" +define KY_SXINNER "sx1" +define KY_SXOUTER "sx2" +define KY_SYINNER "sy1" +define KY_SYOUTER "sy2" +define KY_RADSYM "radsym" +define KY_THRESHOLD "threshold" + +define KY_NORMFACTOR "normfactor" + diff --git a/pkg/images/immatch/src/psfmatch/psfmatch.key b/pkg/images/immatch/src/psfmatch/psfmatch.key new file mode 100644 index 00000000..57ef3b2e --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/psfmatch.key @@ -0,0 +1,50 @@ + Interactive Keystroke Commands + + +? Print help +: Colon commands +k Draw a contour plot of the psf matching kernel +p Draw a contour plot of the psf matching kernel power spectrum +x Draw a column plot of the psf matching kernel / power spectrum +y Draw a line plot of the psf matching kernel / power spectrum +r Redraw the current plot +f Recompute the psf matching kernel +w Update the task parameters +q Exit + + + Colon Commands + + +:mark [file] Mark objects on the display +:show Show current values of the parameters + + + Show/Set Parameters + +:input [string] Show/set the current input image name +:reference [string] Show/set the current reference image/psf name +:psf [file/string] Show/set the objects/input psf list +:psfimage [string] Show/set the current input psf name +:kernel [string] Show/set the current psf matching kernel name +:output [string] Show/set the current output image name + +:dnx [value] Show/set x width of data region(s) to extract +:dny [value] Show/set y width of data region(s) to extract +:pnx [value] Show/set x width of psf matching kernel +:pny [value] Show/set y width of psf matching kernel +:center [yes/no] Show/set the centering switch +:background [string] Show/set the background fitting function +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +:apodize [value] Show/set percent of endpoints to apodize + +:filter [string] Show/set the filtering algorithm +:fluxratio [value] Show/set the reference/input psf flux ratio +:sx1 [value] Show/set inner x frequency for cosbell filter +:sx2 [value] Show/set outer x frequency for cosbell filter +:sy1 [value] Show/set inner y frequency for cosbell filter +:sy2 [value] Show/set outer y frequency for cosbell filter +:radsym [yes/no] Show/set radial symmetry for cosbell filter +:threshold [value] Show/set %threshold for replace/modeling filter +:normfactor [value] Show/set the kernel normalization factor diff --git a/pkg/images/immatch/src/psfmatch/rgpbckgrd.x b/pkg/images/immatch/src/psfmatch/rgpbckgrd.x new file mode 100644 index 00000000..1670b943 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpbckgrd.x @@ -0,0 +1,70 @@ +include +include +include "psfmatch.h" + +# RG_PSCALE -- Compute the background offset and x and y slope. + +procedure rg_pscale (pm, data, npts, nx, ny, pnx, pny, offset, coeff) + +pointer pm #I pointer to the psfmatch structure +real data[ARB] #I the input data +int npts #I the number of points +int nx, ny #I the dimensions of the original subraster +int pnx, pny #I the dimensions of the data region +real offset #I the input offset +real coeff[ARB] #O the output coefficients + +int wxborder, wyborder +pointer gs +real loreject, hireject, zero +int rg_pstati(), rg_znsum(), rg_znmedian(), rg_slope() +real rg_pstatr() + +begin + loreject = rg_pstatr (pm, LOREJECT) + hireject = rg_pstatr (pm, HIREJECT) + + switch (rg_pstati (pm, BACKGRD)) { + case PM_BNONE: + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BNUMBER: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BMEAN: + if (rg_znsum (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BMEDIAN: + if (rg_znmedian (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case PM_BSLOPE: + call gsinit (gs, GS_POLYNOMIAL, 2, 2, GS_XNONE, 1.0, real (nx), 1.0, + real (ny)) + wxborder = (nx - pnx) / 2 + wyborder = (ny - pny) / 2 + if (rg_slope (gs, data, npts, nx, ny, wxborder, wyborder, loreject, + hireject) == ERR) { + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } else { + call gssave (gs, coeff) + coeff[1] = coeff[GS_SAVECOEFF+1] + coeff[2] = coeff[GS_SAVECOEFF+2] + coeff[3] = coeff[GS_SAVECOEFF+3] + } + call gsfree (gs) + default: + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpcolon.x b/pkg/images/immatch/src/psfmatch/rgpcolon.x new file mode 100644 index 00000000..8eefb22d --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpcolon.x @@ -0,0 +1,501 @@ +include +include +include +include "psfmatch.h" + +# RG_PCOLON -- Show/set the psfmatch task algorithm parameters. + +procedure rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, imfourier, im2, + cmdstr, newref, newdata, newfourier, newfilter) + +pointer gd #I pointer to the graphics stream +pointer pm #I pointer to psfmatch structure +pointer imr #I pointer to the reference image +int reglist #I the regions / psf list descriptor +pointer impsf #I pointer to the regions list +pointer im1 #I pointer to the input image +pointer imk #I pointer to kernel image +pointer imfourier #I pointer to fourier spectrum image +pointer im2 #I pointer to the output image +char cmdstr[ARB] #I command string +int newref #I/O new reference image +int newdata #I/O new input image +int newfourier #I/O new FFT +int newfilter #I/O new filter + +bool bval +int ncmd, ival, stat, fd, ip +pointer sp, cmd, str +real rval +bool itob() +bool streq() +int strdic(), nscan(), rg_pstati(), btoi(), rg_pregions(), fntopnb() +int access(), rg_pmkregions(), open(), ctor() +pointer immap() +real rg_pstatr() +errchk immap(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PMCMDS) + switch (ncmd) { + case PMCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + if (imr == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_psets (pm, REFIMAGE, Memc[cmd]) + newref = YES; newdata = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_IMAGE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Reference image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else { + call rg_psets (pm, IMAGE, Memc[cmd]) + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_PSFDATA: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, PSFDATA, Memc[str], SZ_FNAME) + if (reglist == NULL || nscan() == 1 || (streq (Memc[cmd], + Memc[str]) && Memc[cmd] != EOS)) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_PSFDATA) + call pargstr (Memc[str]) + } else if (rg_pstati(pm, CONVOLUTION) == PM_CONIMAGE) { + call fntclsb (reglist) + iferr { + reglist = fntopnb (Memc[cmd], NO) + } then { + reglist = fntopnb (Memc[str], NO) + } else { + if (rg_pregions (reglist, imr, pm, 1, NO) > 0) + ; + call rg_psets (pm, PSFDATA, Memc[cmd]) + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_PSFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, PSFIMAGE, Memc[str], SZ_FNAME) + if (impsf == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_PSFIMAGE) + call pargstr (Memc[str]) + } else { + if (impsf != NULL) { + call imunmap (impsf) + impsf = NULL + } + iferr { + impsf = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + impsf = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(impsf) > 2 || IM_NDIM(impsf) != + IM_NDIM(imr)) { + call printf ( + "PSF image has the wrong number of dimensions\n") + call imunmap (impsf) + impsf = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_psets (pm, PSFIMAGE, Memc[cmd]) + newref = YES; newdata = YES + newfourier = YES; newfilter = YES + } + } + + case PMCMD_KERNEL: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, KERNEL, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_KERNEL) + call pargstr (Memc[str]) + } else { + if (imk != NULL) { + call imunmap (imk) + call imdelete (Memc[str]) + imk = NULL + } + iferr { + imk = immap (Memc[cmd], NEW_IMAGE, 0) + } then { + call erract (EA_WARN) + imk = NULL + call rg_psets (pm, KERNEL, "") + } else + call rg_psets (pm, KERNEL, Memc[cmd]) + } + + + case PMCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_pstats (pm, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_psets (pm, OUTIMAGE, Memc[cmd]) + } + } + + case PMCMD_DNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DNX) + call pargi (rg_pstati (pm, DNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNX, ival) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_DNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_DNY) + call pargi (rg_pstati (pm, DNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNY, ival) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_PNX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_PNX) + call pargi (rg_pstati (pm, PNX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNX, min (ival, rg_pstati (pm, DNX))) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_PNY: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_PNY) + call pargi (rg_pstati (pm, PNY)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNY, min (ival, rg_pstati(pm, DNY))) + newref = YES; newdata = YES; newfourier = YES; newfilter = YES + } + + case PMCMD_CENTER: + call gargb (bval) + if (nscan() == 1) { + call printf ("%s = %b\n") + call pargstr (KY_CENTER) + call pargb (itob (rg_pstati (pm, CENTER))) + } else { + call rg_pseti (pm, CENTER, btoi (bval)) + newfourier = YES; newfilter = YES + } + + case PMCMD_BACKGRD: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_pstats (pm, BSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_BACKGRD) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PM_BTYPES) + ip = 1 + if (stat > 0) { + call rg_pseti (pm, BACKGRD, stat) + call rg_psets (pm, BSTRING, Memc[cmd]) + newfourier = YES; newfilter = YES + } else if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUE, rval) + if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUER, rval) + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, PM_NUMBER) + } else { + call rg_psetr (pm, BVALUE, 0.0) + call rg_psetr (pm, BVALUER, 0.0) + } + } + } + + case PMCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_pstatr (pm, LOREJECT)) + } else { + call rg_psetr (pm, LOREJECT, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_pstatr (pm, HIREJECT)) + } else { + call rg_psetr (pm, HIREJECT, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_APODIZE: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_pstatr (pm, APODIZE)) + } else { + call rg_psetr (pm, APODIZE, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_CONVOLUTION: + if (Memc[cmd] == EOS) { + call rg_pstats (pm, CSTRING, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_CONVOLUTION) + call pargstr (Memc[str]) + } + + case PMCMD_UFLUXRATIO: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_UFLUXRATIO) + call pargr (rg_pstatr (pm, UFLUXRATIO)) + } else { + call rg_psetr (pm, UFLUXRATIO, rval) + newfourier = YES; newfilter = YES + } + + case PMCMD_FILTER: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call printf ("%s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PM_FTYPES) + if (stat > 0) { + call rg_pseti (pm, FILTER, stat) + call rg_psets (pm, FSTRING, Memc[cmd]) + } + newfilter = YES + } + + case PMCMD_SXINNER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SXINNER) + call pargr (rg_pstatr (pm, SXINNER)) + } else { + call rg_psetr (pm, SXINNER, rval) + newfilter = YES + } + + case PMCMD_SXOUTER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SXOUTER) + call pargr (rg_pstatr (pm, SXOUTER)) + } else { + call rg_psetr (pm, SXOUTER, rval) + newfilter = YES + } + + case PMCMD_SYINNER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SYINNER) + call pargr (rg_pstatr (pm, SYINNER)) + } else { + call rg_psetr (pm, SYINNER, rval) + newfilter = YES + } + + case PMCMD_SYOUTER: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_SYOUTER) + call pargr (rg_pstatr (pm, SYOUTER)) + } else { + call rg_psetr (pm, SYOUTER, rval) + newfilter = YES + } + + case PMCMD_RADSYM: + call gargb (bval) + if (nscan() == 1) { + call printf ("%s = %b\n") + call pargstr (KY_RADSYM) + call pargb (itob (rg_pstati (pm, RADSYM))) + } else { + call rg_pseti (pm, RADSYM, btoi (bval)) + newfilter = YES + } + + case PMCMD_THRESHOLD: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_THRESHOLD) + call pargr (rg_pstatr (pm, THRESHOLD)) + } else { + call rg_psetr (pm, THRESHOLD, rval) + newfilter = YES + } + + case PMCMD_NORMFACTOR: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_NORMFACTOR) + call pargr (rg_pstatr (pm, NORMFACTOR)) + } else { + call rg_psetr (pm, NORMFACTOR, rval) + newfilter = YES + } + + case PMCMD_SHOW: + call gdeactivate (gd, 0) + call rg_pshow (pm) + call greactivate (gd, 0) + + case PMCMD_MARK: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + fd = NULL + } else if (access (Memc[cmd], 0, 0) == YES) { + call printf ("Warning: file %s already exists\n") + call pargstr (Memc[cmd]) + fd = NULL + } else { + fd = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } + call printf ("\n") + if (rg_pmkregions (fd, imr, pm, 1, MAX_NREGIONS) <= 0) + call printf ("The regions list is empty\n") + newdata = YES; newref = YES + newfourier = YES; newfilter = YES + call printf ("\n") + if (fd != NULL) + call close (fd) + call greactivate (gd, 0) + + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgpconvolve.x b/pkg/images/immatch/src/psfmatch/rgpconvolve.x new file mode 100644 index 00000000..6b516a95 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpconvolve.x @@ -0,0 +1,106 @@ +include +include +include + +# RG_PCONVOLVE -- Convolve an image with an nxk by nyk kernel. The kernel +# dimensions are assumed to be odd. + +procedure rg_pconvolve (im1, im2, kernel, nxk, nyk, boundary, constant) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +real kernel[nxk,nyk] # the convolution kernel +int nxk, nyk # dimensions of the kernel +int boundary # type of boundary extension +real constant # constant for constant boundary extension + +int i, ncols, nlines, col1, col2, nincols, inline, outline +pointer sp, lineptrs, linebuf, outbuf, nkern +pointer imgs2r(), impl2r() +errchk imgs2r, impl2r + +begin + # Set up an array of line pointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + call salloc (nkern, nxk * nyk, TY_REAL) + + # Set the number of image buffers. + call imseti (im1, IM_NBUFS, nyk) + + # Set the input image boundary conditions. + call imseti (im1, IM_TYBNDRY, boundary) + call imseti (im1, IM_NBNDRYPIX, max (nxk / 2 + 1, nyk / 2 + 1)) + if (boundary == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the number of output image lines and columns. + ncols = IM_LEN(im2,1) + if (IM_NDIM(im2) == 1) + nlines = 1 + else + nlines = IM_LEN(im2,2) + + # Set the input image column limits. + col1 = 1 - nxk / 2 + col2 = IM_LEN(im1,1) + nxk / 2 + nincols = col2 - col1 + 1 + + # Flip the kernel + call rg_pflip (kernel, Memr[nkern], nxk, nyk) + + # Initialise the line buffers. + inline = 1 - nyk / 2 + do i = 1 , nyk - 1 { + Memi[lineptrs+i] = imgs2r (im1, col1, col2, inline, inline) + inline = inline + 1 + } + + # Generate the output image line by line + call salloc (linebuf, nincols, TY_REAL) + do outline = 1, nlines { + + # Scroll the input buffers + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + + # Read in new image line + Memi[lineptrs+nyk-1] = imgs2r (im1, col1, col2, inline, + inline) + + # Get output image line + outbuf = impl2r (im2, outline) + if (outbuf == EOF) + call error (0, "Error writing output image.") + + # Generate output image line + call aclrr (Memr[outbuf], ncols) + do i = 1, nyk + call acnvr (Memr[Memi[lineptrs+i-1]], Memr[outbuf], ncols, + Memr[nkern+(i-1)*nxk], nxk) + + inline = inline + 1 + } + + # Free the image buffer pointers + call sfree (sp) +end + + +# RG_PFLIP -- Flip the kernel in preparation for convolution. + +procedure rg_pflip (inkern, outkern, nxk, nyk) + +real inkern[nxk,nyk] # the input kernel +real outkern[nxk,nyk] # the output kernel +int nxk, nyk # the kernel dimensions + +int i, j + +begin + do j = 1, nyk { + do i = 1, nxk { + outkern[i,j] = inkern[nxk+1-i,nyk+1-j] + } + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpfft.x b/pkg/images/immatch/src/psfmatch/rgpfft.x new file mode 100644 index 00000000..b5f36375 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpfft.x @@ -0,0 +1,443 @@ + +# RG_PG10F -- Fetch the 0 component of the fft. + +real procedure rg_pg10f (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + return (fft[xcen,ycen]) +end + + +# RG_PG1NORM -- Estimate the normalization factor by computing the amplitude +# of the best fitting Gaussian. This routine may eventually be replaced by +# on which does a complete Gaussian fit. The Gaussian is assumed to be +# of the form g = a * exp (b * r * r). The input array is a 2D real array +# storing 1 fft of dimension nxfft by nyfft in complex order with the +# zero frequency in the center. + +real procedure rg_pg1norm (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen +real ln1, ln2, cx, cy + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + if (nxfft >= 8) { + ln1 = log (sqrt (fft[xcen-2,ycen] ** 2 + fft[xcen-1,ycen] ** 2)) + ln2 = log (sqrt (fft[xcen-4,ycen] ** 2 + fft[xcen-3,ycen] ** 2)) + cx = exp ((4.0 * ln1 - ln2) / 3.0) + } else + cx = 0.0 + + if (nyfft >= 4) { + ln1 = log (sqrt (fft[xcen,ycen-1] ** 2 + fft[xcen+1,ycen-1] ** 2)) + ln2 = log (sqrt (fft[xcen,ycen-2] ** 2 + fft[xcen+1,ycen-2] ** 2)) + cy = exp ((4.0 * ln1 - ln2) / 3.0) + } else + cy = 0.0 + + if (cx <= 0.0) + return (cy) + else if (cy <= 0.0) + return (cx) + else + return (0.5 * (cx + cy)) +end + + +# RG_PG20F -- Fetch the 0 component of the fft. + +real procedure rg_pg20f (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen + +begin + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + return (fft[xcen,ycen] / fft[xcen+1,ycen]) +end + + +# RG_PG2NORM -- Estimate the normalization factor by computing the amplitude +# of the best fitting Gaussian. This routine may eventually be replaced by +# on which does a complete Gaussian fit. The Gaussian is assumed to be +# of the form g = a * exp (b * r * r). The input array is a 2D real array +# storing 2 2D ffts of dimension nxfft by nyfft in complex order with the +# zero frequency in the center. + +real procedure rg_pg2norm (fft, nxfft, nyfft) + +real fft[nxfft,nyfft] #I array containing 2 real ffts +int nxfft #I x dimension of complex array +int nyfft #I y dimension of complex array + +int xcen, ycen +real fftr, ffti, ln1r, ln2r, ln1i, ln2i, cxr, cyr, cxi, cyi, ampr, ampi + +begin + + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + # Compute the x amplitude for the first fft. + if (nxfft >= 8) { + + fftr = 0.5 * (fft[xcen+2,ycen] + fft[xcen-2,ycen]) + ffti = 0.5 * (fft[xcen+3,ycen] - fft[xcen-1,ycen]) + ln1r = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+4,ycen] + fft[xcen-4,ycen]) + ffti = 0.5 * (fft[xcen+5,ycen] - fft[xcen-3,ycen]) + ln2r = log (sqrt (fftr ** 2 + ffti ** 2)) + + fftr = 0.5 * (fft[xcen+3,ycen] + fft[xcen-1,ycen]) + ffti = -0.5 * (fft[xcen+2,ycen] - fft[xcen-2,ycen]) + ln1i = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+5,ycen] + fft[xcen-3,ycen]) + ffti = -0.5 * (fft[xcen+4,ycen] - fft[xcen-4,ycen]) + ln2i = log (sqrt (fftr ** 2 + ffti ** 2)) + + cxr = exp ((4.0 * ln1r - ln2r) / 3.0) + cxi = exp ((4.0 * ln1i - ln2i) / 3.0) + + } else { + + cxr = 0.0 + cxi = 0.0 + + } + + # Compute the y ratio. + if (nyfft >= 4) { + + fftr = 0.5 * (fft[xcen,ycen+1] + fft[xcen,ycen-1]) + ffti = 0.5 * (fft[xcen+1,ycen+1] - fft[xcen+1,ycen-1]) + ln1r = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen,ycen+2] + fft[xcen,ycen-2]) + ffti = 0.5 * (fft[xcen+1,ycen+2] - fft[xcen+1,ycen-2]) + ln2r = log (sqrt (fftr ** 2 + ffti ** 2)) + + fftr = 0.5 * (fft[xcen+1,ycen+1] + fft[xcen+1,ycen-1]) + ffti = -0.5 * (fft[xcen,ycen+1] - fft[xcen,ycen-1]) + ln1i = log (sqrt (fftr ** 2 + ffti ** 2)) + fftr = 0.5 * (fft[xcen+1,ycen+2] + fft[xcen+1,ycen-2]) + ffti = -0.5 * (fft[xcen,ycen+2] - fft[xcen,ycen-2]) + ln2i = log (sqrt (fftr ** 2 + ffti ** 2)) + + cyr = exp ((4.0 * ln1r - ln2r) / 3.0) + cyi = exp ((4.0 * ln1i - ln2i) / 3.0) + + } else { + + cyr = 0.0 + cyi = 0.0 + + } + + if (cxr <= 0.0) + ampr = cyr + else if (cyr <= 0.0) + ampr = cxr + else + ampr = 0.5 * (cxr + cyr) + + if (cxi <= 0.0) + ampi = cyi + else if (cyi <= 0.0) + ampi = cxi + else + ampi = 0.5 * (cxi + cyi) + + if (ampi <= 0.0) + return (INDEFR) + else + return (ampr /ampi) +end + + +# RG_PDIVFFT -- Unpack the two fft's, save the first fft, and compute the +# quotient of the two ffts. + +procedure rg_pdivfft (fft1, fftnum, fftdenom, fft2, nxfft, nyfft) + +real fft1[nxfft,nyfft] # array containing 2 ffts of 2 real functions +real fftnum[nxfft,nyfft] # the numerator fft +real fftdenom[nxfft,nyfft] # the denominator fft +real fft2[nxfft,nyfft] # fft of psf matching function +int nxfft, nyfft # dimensions of fft + +int i, j, xcen, ycen, nxp2, nxp3, nyp2 +real c1, c2, h1r, h1i, h2r, h2i, denom + +begin + c1 = 0.5 + c2 = -0.5 + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + nxp2 = nxfft + 2 + nxp3 = nxfft + 3 + nyp2 = nyfft + 2 + + # Compute the 0 frequency point. + h1r = fft1[xcen,ycen] + h1i = 0.0 + h2r = fft1[xcen+1,ycen] + h2i = 0.0 + fftnum[xcen,ycen] = h1r + fftnum[xcen+1,ycen] = 0.0 + fftdenom[xcen,ycen] = h2r + fftdenom[xcen+1,ycen] = 0.0 + fft2[xcen,ycen] = h1r / h2r + fft2[xcen+1,ycen] = 0.0 + + #call eprintf ("fft11=%g fft21=%g\n") + #call pargr (fft1[1,1]) + #call pargr (fft1[2,1]) + + # Compute the first point. + h1r = c1 * (fft1[1,1] + fft1[1,1]) + h1i = 0.0 + h2r = -c2 * (fft1[2,1] + fft1[2,1]) + h2i = 0.0 + + fftnum[1,1] = h1r + fftnum[2,1] = h1i + fftdenom[1,1] = h2r + fftdenom[2,1] = h2i + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[1,1] = 1.0 + fft2[2,1] = 0.0 + } else { + fft2[1,1] = (h1r * h2r + h1i * h2i) / denom + fft2[2,1] = (h1i * h2r - h2i * h1r) / denom + } + + # Compute the x symmetry axis points. + do i = 3, xcen - 1, 2 { + + h1r = c1 * (fft1[i,ycen] + fft1[nxp2-i,ycen]) + h1i = c1 * (fft1[i+1,ycen] - fft1[nxp3-i,ycen]) + h2r = -c2 * (fft1[i+1,ycen] + fft1[nxp3-i,ycen]) + h2i = c2 * (fft1[i,ycen] - fft1[nxp2-i,ycen]) + + fftnum[i,ycen] = h1r + fftnum[i+1,ycen] = h1i + fftnum[nxp2-i,ycen] = h1r + fftnum[nxp3-i,ycen] = -h1i + + fftdenom[i,ycen] = h2r + fftdenom[i+1,ycen] = h2i + fftdenom[nxp2-i,ycen] = h2r + fftdenom[nxp3-i,ycen] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,ycen] = 1.0 + fft2[i+1,ycen] = 0.0 + } else { + fft2[i,ycen] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,ycen] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,ycen] = fft2[i,ycen] + fft2[nxp3-i,ycen] = -fft2[i+1,ycen] + + } + + # Quit if the transform is 1D. + if (nyfft < 2) + return + + # Compute the x axis points. + do i = 3, xcen + 1, 2 { + + h1r = c1 * (fft1[i,1] + fft1[nxp2-i,1]) + h1i = c1 * (fft1[i+1,1] - fft1[nxp3-i,1]) + h2r = -c2 * (fft1[i+1,1] + fft1[nxp3-i,1]) + h2i = c2 * (fft1[i,1] - fft1[nxp2-i,1]) + + fftnum[i,1] = h1r + fftnum[i+1,1] = h1i + fftnum[nxp2-i,1] = h1r + fftnum[nxp3-i,1] = -h1i + + fftdenom[i,1] = h2r + fftdenom[i+1,1] = h2i + fftdenom[nxp2-i,1] = h2r + fftdenom[nxp3-i,1] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0) { + fft2[i,1] = 1.0 + fft2[i+1,1] = 0.0 + } else { + fft2[i,1] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,1] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,1] = fft2[i,1] + fft2[nxp3-i,1] = -fft2[i+1,1] + } + + # Compute the y symmetry axis points. + do i = 2, ycen - 1 { + + h1r = c1 * (fft1[xcen,i] + fft1[xcen, nyp2-i]) + h1i = c1 * (fft1[xcen+1,i] - fft1[xcen+1,nyp2-i]) + h2r = -c2 * (fft1[xcen+1,i] + fft1[xcen+1,nyp2-i]) + h2i = c2 * (fft1[xcen,i] - fft1[xcen,nyp2-i]) + + fftnum[xcen,i] = h1r + fftnum[xcen+1,i] = h1i + fftnum[xcen,nyp2-i] = h1r + fftnum[xcen+1,nyp2-i] = -h1i + + fftdenom[xcen,i] = h2r + fftdenom[xcen+1,i] = h2i + fftdenom[xcen,nyp2-i] = h2r + fftdenom[xcen+1,nyp2-i] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[xcen,i] = 1.0 + fft2[xcen+1,i] = 0.0 + } else { + fft2[xcen,i] = (h1r * h2r + h1i * h2i) / denom + fft2[xcen+1,i] = (h1i * h2r - h2i * h1r) / denom + } + fft2[xcen,nyp2-i] = fft2[xcen,i] + fft2[xcen+1,nyp2-i] = -fft2[xcen+1,i] + + } + + # Compute the y axis points. + do i = 2, ycen { + + h1r = c1 * (fft1[1,i] + fft1[1,nyp2-i]) + h1i = c1 * (fft1[2,i] - fft1[2,nyp2-i]) + h2r = -c2 * (fft1[2,i] + fft1[2,nyp2-i]) + h2i = c2 * (fft1[1,i] - fft1[1,nyp2-i]) + + fftnum[1,i] = h1r + fftnum[2,i] = h1i + fftnum[1,nyp2-i] = h1r + fftnum[2,nyp2-i] = -h1i + + fftdenom[1,i] = h2r + fftdenom[2,i] = h2i + fftdenom[1,nyp2-i] = h2r + fftdenom[2,nyp2-i] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[1,i] = 1.0 + fft2[2,i] = 0.0 + } else { + fft2[1,i] = (h1r * h2r + h1i * h2i) / denom + fft2[2,i] = (h1i * h2r - h2i * h1r) / denom + } + fft2[1,nyp2-i] = fft2[1,i] + fft2[2,nyp2-i] = -fft2[2,i] + } + + # Compute the remainder of the transform. + do j = 2, ycen - 1 { + + do i = 3, xcen - 1, 2 { + + h1r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h1i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h2r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h2i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + + fftnum[i,j] = h1r + fftnum[i+1,j] = h1i + fftnum[nxp2-i,nyp2-j] = h1r + fftnum[nxp3-i,nyp2-j] = -h1i + + fftdenom[i,j] = h2r + fftdenom[i+1,j] = h2i + fftdenom[nxp2-i,nyp2-j] = h2r + fftdenom[nxp3-i,nyp2-j] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,j] = 1.0 + fft2[i+1,j] = 0.0 + } else { + fft2[i,j] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,j] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + } + + do i = xcen + 2, nxfft, 2 { + + h1r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h1i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h2r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h2i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + + fftnum[i,j] = h1r + fftnum[i+1,j] = h1i + fftnum[nxp2-i,nyp2-j] = h1r + fftnum[nxp3-i,nyp2-j] = -h1i + + fftdenom[i,j] = h2r + fftdenom[i+1,j] = h2i + fftdenom[nxp2-i,nyp2-j] = h2r + fftdenom[nxp3-i,nyp2-j] = -h2i + + denom = h2r * h2r + h2i * h2i + if (denom == 0.0) { + fft2[i,j] = 1.0 + fft2[i+1,j] = 0.0 + } else { + fft2[i,j] = (h1r * h2r + h1i * h2i) / denom + fft2[i+1,j] = (h1i * h2r - h2i * h1r) / denom + } + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + + } + } +end + + +# RG_PNORM -- Insert the normalization value into the 0 frequency of the +# fft. The fft is a 2D fft stored in a real array in complex order. +# The fft is assumed to be centered. + +procedure rg_pnorm (fft, nxfft, nyfft, norm) + +real fft[ARB] #I the input fft +int nxfft #I the x dimension of fft (complex storage) +int nyfft #I the y dimension of the fft +real norm #I the flux ratio + +int index + +begin + index = nxfft + 1 + 2 * (nyfft / 2) * nxfft + fft[index] = norm + fft[index+1] = 0.0 +end diff --git a/pkg/images/immatch/src/psfmatch/rgpfilter.x b/pkg/images/immatch/src/psfmatch/rgpfilter.x new file mode 100644 index 00000000..63040b63 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpfilter.x @@ -0,0 +1,502 @@ +include + +# RG_PCOSBELL -- Apply a cosine bell function to the data. + +procedure rg_pcosbell (fft, nxfft, nyfft, sx1, sx2, sy1, sy2, radsym) + +real fft[ARB] #I/O the ifft to be filtered +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real sx1 #I inner x radius of the cosine bell filter +real sx2 #I outer x radius of the cosine bell filter +real sy1 #I inner y radius of the cosine bell filter +real sy2 #I outer y radius of the cosine bell filter +int radsym #I radial symmetry ? + +int i, j, index, xcen, ycen +real factorx, factory, r1, r2, r, rj, cos2 + +begin + # Compute the center of the fft. + xcen = (nxfft / 2) + 1 + ycen = (nyfft / 2) + 1 + + if (radsym == NO) { + + # Filter in the y direction independently. + if (IS_INDEFR(sy1)) + r1 = 0.0 + else + r1 = sy1 + if (IS_INDEFR(sy2)) + r2 = nyfft - ycen + 1 + else + r2 = sy2 + factory = HALFPI / (r2 - r1) + index = 1 + do j = 1, nyfft { + r = abs (ycen - j) + if (r >= r2) + cos2 = 0.0 + else if (r <= r1) + cos2 = 1.0 + else + cos2 = cos ((r - r1) * factory) ** 2 + call amulkr (fft[index], cos2, fft[index], 2 * nxfft) + index = index + 2 * nxfft + } + + # Filter in the x direction independently. + if (IS_INDEFR(sx1)) + r1 = 0.0 + else + r1 = sx1 + if (IS_INDEFR(sx2)) + r2 = nxfft - xcen + 1 + else + r2 = sx2 + factorx = HALFPI / (r2 - r1) + + do i = 1, nxfft { + r = abs (xcen - i) + if (r >= r2) + cos2 = 0.0 + else if (r <= r1) + cos2 = 1.0 + else + cos2 = cos ((r - r1) * factorx) ** 2 + do j = 2 * i - 1, 2 * nxfft * nyfft, 2 * nxfft { + fft[j] = fft[j] * cos2 + fft[j+1] = fft[j+1] * cos2 + } + } + + } else { + + if (IS_INDEFR(sx1) && IS_INDEFR(sy1)) + r1 = 0.0 + else if (IS_INDEFR(sx1)) + r1 = sy1 + else if (IS_INDEFR(sy1)) + r1 = sx1 + else + r1 = (sx1 + sy1) / 2.0 + if (IS_INDEFR(sx2) && IS_INDEFR(sy2)) + r2 = (nxfft - xcen + 1 + nyfft - ycen + 1) / 2.0 + else if (IS_INDEFR(sx2)) + r2 = sy2 + else if (IS_INDEFR(sy2)) + r2 = sx2 + else + r2 = (sx2 + sy2) / 2.0 + factorx = HALFPI / (r2 - r1) + + index = 0 + do j = 1, nyfft { + rj = (ycen - j) ** 2 + do i = 1, nxfft { + r = sqrt ((i - xcen) ** 2 + rj) + if (r >= r2) { + fft[index+2*i-1] = 0.0 + fft[index+2*i] = 0.0 + } else if (r > r1) { + fft[index+2*i-1] = fft[index+2*i-1] * cos ((r - r1) * + factorx) ** 2 + fft[index+2*i] = fft[index+2*i] * cos ((r - r1) * + factorx) ** 2 + } + } + index = index + 2 * nxfft + } + } +end + + +# RG_PREPLACE -- Replace low valued regions in the kernel fft with a Gaussian +# extension. + +procedure rg_preplace (fft, fftdiv, nxfft, nyfft, pthreshold, norm) + +real fft[ARB] #I/O the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I x dimension of the fft (complex storage) +int nyfft #I y dimension of the fft +real pthreshold #I the minimum percent amplitude in the divisor +real norm #I the normalization value + +pointer sp, params +int xcen, ycen, i, j, ri, rj, index +real divpeak, a1, a2, a3, u, v, divisor, absv, phi + +begin + call smark (sp) + call salloc (params, 5, TY_REAL) + + # Compute the central amplitude peak. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + divpeak = pthreshold * fftdiv[1+nxfft+2*(ycen-1)*nxfft] + + # Fit the parameters. + call rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, + Memr[params]) + + # Store the parameters in temporary variables. + a1 = Memr[params] + a2 = Memr[params+1] + a3 = Memr[params+2] + u = Memr[params+3] + v = Memr[params+4] + + # Perform the extension. + index = 0 + do j = 1, nyfft { + rj = j - ycen + do i = 1, nxfft { + ri = i - xcen + divisor = sqrt (fftdiv[index+2*i-1] ** 2 + + fftdiv[index+2*i] ** 2) + if (divisor < divpeak) { + absv = norm * exp (a1 * ri * ri + a2 * ri * rj + a3 * + rj * rj) + phi = u * ri + v * rj + fft[index+2*i-1] = absv * cos (phi) + fft[index+2*i] = absv * sin (phi) + } + } + index = index + 2 * nxfft + } + + # Correct the first row. + do i = 1, 2 * nxfft, 2 { + fft[i] = sqrt (fft[i] ** 2 + fft[i+1] ** 2) + fft[i+1] = 0.0 + } + + # Correct the first column. + index = 1 + do j = 2, nyfft { + fft[index] = sqrt (fft[index] ** 2 + fft[index+1] ** 2) + fft[index+1] = 0.0 + index = index + 2 * nxfft + } + + call sfree (sp) +end + + +# RG_PGMODEL -- Replace low values with a Gaussian mode. + +procedure rg_pgmodel (fft, fftdiv, nxfft, nyfft, pthreshold, norm) + +real fft[ARB] #I/O the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real pthreshold #I the minimum percent amplitude in the divisor +real norm #I the normalization factor + +pointer sp, params +int xcen, ycen, i, j, index +real divpeak, a1, a2, a3, u, v, absv, phi, ri, rj + +begin + call smark (sp) + call salloc (params, 5, TY_REAL) + + # Compute the central amplitude peak. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + divpeak = pthreshold * fftdiv[1+nxfft+2*(ycen-1)*nxfft] + + # Fit the parameters. + call rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, + Memr[params]) + + # Store the parameters in temporary variables + a1 = Memr[params] + a2 = Memr[params+1] + a3 = Memr[params+2] + u = Memr[params+3] + v = Memr[params+4] + + # Perform the extension. + index = 0 + do j = 1, nyfft { + rj = j - ycen + do i = 1, nxfft { + ri = i - xcen + absv = norm * exp (a1 * ri * ri + a2 * ri * rj + a3 * rj * rj) + phi = u * ri + v * rj + fft[index+2*i-1] = absv * cos (phi) + fft[index+2*i] = absv * sin (phi) + } + index = index + 2 * nxfft + } + + # Correct the first row. + do i = 1, 2 * nxfft, 2 { + fft[i] = sqrt (fft[i] ** 2 + fft[i+1] ** 2) + fft[i+1] = 0.0 + } + + # Correct the first column. + index = 1 + do j = 2, nyfft { + fft[index] = sqrt (fft[index] ** 2 + fft[index+1] ** 2) + fft[index+1] = 0.0 + index = index + 2 * nxfft + } + + call sfree (sp) +end + + +# RG_PGAUSSFIT -- Procedure to compute the Gaussian parameters + +procedure rg_pgaussfit (fft, fftdiv, nxfft, nyfft, divpeak, norm, param) + +real fft[ARB] #I the fft of the kernel +real fftdiv[ARB] #I the divisor fft +int nxfft #I the x dimension of the fft +int nyfft #I the y dimension of the fft +real divpeak #I the minimum value in the divisor +real norm #I the normalization value norm value +real param[ARB] #O the output fitted parameters + +int i, j, yj, xcen, ycen +double x, y, x2, xy, y2, z, wt, x2w, y2w, xyw, zw, xzw, yzw +double sxxxx, sxxxy, sxxyy, sxyyy, syyyy, sxxz, sxyz, syyz, sxx, sxy +double syy, sxz, syz +pointer sp, mat +real divisor + +begin + # Allocate temporary space. + call smark (sp) + call salloc (mat, 12, TY_DOUBLE) + + # Define the center of the fft. + xcen = nxfft / 2 + 1 + ycen = nyfft / 2 + 1 + + # Initialize. + sxxxx = 0.0d0 + sxxxy = 0.0d0 + sxxyy = 0.0d0 + sxyyy = 0.0d0 + syyyy = 0.0d0 + sxxz = 0.0d0 + sxyz = 0.0d0 + syyz = 0.0d0 + sxx = 0.0d0 + sxy = 0.0d0 + syy = 0.0d0 + sxz = 0.0d0 + syz = 0.0d0 + + do i = 1, nxfft { + x = i - xcen + yj = - ycen + do j = 2 * i - 1, 2 * nxfft * nyfft, 2 * nxfft { + yj = yj + 1 + y = yj + + # Skip low points in the fit. + divisor = sqrt (fftdiv[j] ** 2 + fftdiv[j+1] ** 2) + if (divisor < divpeak) + next + if (i == xcen || yj == ycen) + next + + # Accumulate the intermediate products. + divisor = sqrt (fft[j] ** 2 + fft[j+1] ** 2) + if (divisor <= 0.0) + next + z = log (divisor / norm) + x2 = x * x + y2 = y * y + wt = 1.0 / sqrt (x2 + y2) + xy = x * y + x2w = x2 * wt + y2w = y2 * wt + xyw = xy * wt + zw = z * wt + xzw = x * zw + yzw = y * zw + + # Accumulate the sums for the Gaussian. + sxxxx = sxxxx + x2 * x2w + sxxxy = sxxxy + x2 * xyw + sxxyy = sxxyy + x2 * y2w + sxyyy = sxyyy + xy * y2w + syyyy = syyyy + y2 * y2w + sxxz = sxxz + x * xzw + sxyz = sxyz + x * yzw + syyz = syyz + y * yzw + + # New weight and z point. + wt = sqrt (fft[j] ** 2 + fft[j+1] ** 2) / norm + z = atan2 (fft[j+1], fft[j]) + + # Accumulate the sums for the shift determinantion. + sxx = sxx + x2 * wt + sxy = sxy + xy * wt + syy = syy + y2 * wt + sxz = sxz + x * z * wt + syz = syz + y * z * wt + } + } + + # Solve for the gaussian. + Memd[mat] = sxxxx + Memd[mat+1] = sxxxy + Memd[mat+2] = sxxyy + Memd[mat+3] = sxxz + Memd[mat+4] = sxxxy + Memd[mat+5] = sxxyy + Memd[mat+6] = sxyyy + Memd[mat+7] = sxyz + Memd[mat+8] = sxxyy + Memd[mat+9] = sxyyy + Memd[mat+10] = syyyy + Memd[mat+11] = syyz + call rg_pgelim (Memd[mat], 3) + param[1] = Memd[mat+3] + param[2] = Memd[mat+7] + param[3] = Memd[mat+11] + + # Solve for the shift. + Memd[mat] = sxx + Memd[mat+1] = sxy + Memd[mat+2] = sxz + Memd[mat+3] = sxy + Memd[mat+4] = syy + Memd[mat+5] = syz + call rg_pgelim (Memd[mat], 2) + param[4] = Memd[mat+2] + param[5] = Memd[mat+5] + + call sfree (sp) +end + + +# RG_PGELIM -- Solve a matrix using Gaussian elimination. + +procedure rg_pgelim (a, n) + +double a[n+1,n] #I/O matrix to be solved +int n #I number of variables + +int i, j, k +double den, hold + +begin + do k = 1, n { + + den = a[k,k] + if (den == 0.0d0) { # look for non-zero switch + do j = k + 1, n { + if (a[k,k] != 0.0d0) { + do i = k, n + 1 { + hold = a[i,j] + a[i,j] = a[i,k] + a[i,k] = hold + } + den = a[k,k] + } + } + if (den == 0.0d0) # if still zero, skip + next + } + + do i = k, n + 1 + a[i,k] = a[i,k] / den + do j = 1, n { + if (j != k) { + den = a[k,j] + do i = k, n + 1 + a[i,j] = a[i,j] - a[i,k] * den + } + } + } +end + + +# RG_PNORMFILT -- Filter out any values greater than the normalization +# from the kernel fft. + +procedure rg_pnormfilt (fft, nxfft, nyfft, norm) + +real fft[ARB] #I/O the input fft +int nxfft #I the x length of the fft +int nyfft #I the y length of the fft +real norm #I the normalization factor + +int j, i_index + +begin + do j = 1, nyfft { + i_index = 1 + 2 * (j - 1) * nxfft + call rg_pnreplace (fft[i_index], nxfft, norm) + } +end + + +# RG_PFOURIER -- Compute the fourier spectrum of the convolution kernel. + +procedure rg_pfourier (fft, psfft, nxfft, nyfft) + +real fft[ARB] # the input fft +real psfft[ARB] # fourier spectrum of the fft +int nxfft # the x dimension of the fft +int nyfft # the y dimension of the fft + +int j, i_index, o_index + +begin + do j = 1, nyfft { + i_index = 1 + 2 * (j - 1) * nxfft + o_index = 1 + (j - 1) * nxfft + call rg_pvfourier (fft[i_index], psfft[o_index], nxfft) + } +end + + +# RG_PVFOURIER -- Procedure to compute the fourier spectrum of a vector. + +procedure rg_pvfourier (a, b, nxfft) + +real a[ARB] # input vector in complex storage order +real b[ARB] # output vector in real storage order +int nxfft # length of vector + +int i + +begin + do i = 1, nxfft + b[i] = sqrt (a[2*i-1] ** 2 + a[2*i] ** 2) +end + + +# RG_PNREPLACE -- Replace values whose absolute value is greater than the +# flux ratio. + +procedure rg_pnreplace (a, nxfft, norm) + +real a[ARB] #I/O ithe nput vector in complex storage order +int nxfft #I the length of the vector +real norm #I the flux ratio + +int i +real val + +begin + do i = 1, 2 * nxfft, 2 { + val = sqrt (a[i] ** 2 + a[i+1] ** 2) + if (val > norm) { + a[i] = a[i] / val * norm + a[i+1] = a[i+1] / val * norm + } + } +end diff --git a/pkg/images/immatch/src/psfmatch/rgpisfm.x b/pkg/images/immatch/src/psfmatch/rgpisfm.x new file mode 100644 index 00000000..24df8fd7 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpisfm.x @@ -0,0 +1,556 @@ +include +include +include +include "psfmatch.h" + +define HELPFILE "immatch$src/psfmatch/psfmatch.key" + +# Define the plot functions + +define PM_PPOWER 1 +define PM_PKERNEL 2 + +# Define the plot types + +define PM_PCONTOUR 1 +define PM_PLINE 2 +define PM_PCOL 3 + +# RG_PISFM -- Procedure to compute the shifts interactively. + +int procedure rg_pisfm (pm, imr, reglist, impsf, im1, imk, imp, im2, gd, id) + +pointer pm #I pointer to the psfmatch structure +pointer imr #I/O pointer to the reference image/psf +pointer reglist #I/O pointer to the regions list +pointer impsf #I/O pointer to the input psf +pointer im1 #I/O pointer to the input image +pointer imp #I/O pointer to the fourier spectrum image +pointer imk #I/O pointer to the kernel image +pointer im2 #I/O pointer to the output image +pointer gd #I graphics stream pointer +pointer id #I display stream pointer + +int newref, newimage, newfourier, newfilter, plotfunc, plottype, wcs, key +int newplot, ncolr, nliner, ip +pointer sp, cmd +real wx, wy +int rg_pstati(), rg_psfm(), clgcur(), rg_pgqverify(), rg_pgtverify() +int ctoi(), rg_pregions() +pointer rg_pstatp() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + newref = YES + newimage = YES + newfourier = YES + newfilter = YES + ncolr = INDEFI + nliner = INDEFI + plotfunc = PM_PKERNEL + plottype = PM_PCONTOUR + + # Compute the convolution kernel for the current image. + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE && rg_pstati (pm, + NREGIONS) <= 0) { + call gclear (gd) + call gflush (gd) + call printf ("The objects list is empty\n") + } else { + if (rg_psfm (pm, imr, im1, impsf, imk, newref) == OK) { + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, plottype) + newref = NO + newimage = NO + newfourier = NO + newfilter = NO + } else { + call gclear (gd) + call gflush (gd) + call rg_pstats (pm, IMAGE, Memc[cmd], SZ_FNAME) + call printf ("Error computing kernel for image %s\n") + call pargstr (Memc[cmd]) + } + } + newplot = NO + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Quit the task gracefully. + case 'q': + if (rg_pgqverify ("psfmatch", pm, imk, key) == YES) { + call sfree (sp) + return (rg_pgtverify (key)) + } + + # Process colon commands. + case ':': + for (ip = 1; IS_WHITE(Memc[cmd+ip-1]); ip = ip + 1) + ; + switch (Memc[cmd+ip-1]) { + + case 'x': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, + NULL, im2, Memc[cmd], newref, newimage, + newfourier, newfilter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, ncolr) <= 0) { + switch (plotfunc) { + case PM_PPOWER: + ncolr = rg_pstati (pm, NXFFT) / 2 + 1 + case PM_PKERNEL: + ncolr = rg_pstati (pm, KNX) / 2 + 1 + default: + ncolr = rg_pstati (pm, KNX) / 2 + 1 + } + } + plottype = PM_PCOL + newplot = YES + } + + case 'y': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, + NULL, im2, Memc[cmd], newref, newimage, + newfourier, newfilter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, nliner) <= 0) { + switch (plotfunc) { + case PM_PPOWER: + nliner = rg_pstati (pm, NYFFT) / 2 + 1 + case PM_PKERNEL: + nliner = rg_pstati (pm, KNY) / 2 + 1 + default: + nliner = rg_pstati (pm, KNY) / 2 + 1 + } + } + plottype = PM_PLINE + newplot = YES + } + + + default: + call rg_pcolon (gd, pm, imr, reglist, impsf, im1, imk, NULL, + im2, Memc[cmd], newref, newimage, newfourier, + newfilter) + } + + # Write the parameters to the parameter file. + case 'w': + call rg_pppars (pm) + + # Recompute the convolution kernel function. + case 'f': + + if (rg_pstati(pm,CONVOLUTION) == PM_CONIMAGE) { + if (newref == YES) + if (rg_pregions (reglist, imr, pm, 1, YES) > 0) + ; + else if (newimage == YES) + call rg_pindefr (pm) + } + + if (rg_pstati (pm, NREGIONS) > 0 || rg_pstati (pm, + CONVOLUTION) != PM_CONIMAGE) { + + if (newfourier == YES) { + call printf ( + "\nRecomputing convolution kernel ...\n") + if (rg_psfm (pm, imr, im1, impsf, imk, + newref) == OK) { + ncolr = INDEFI + nliner = INDEFI + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, + plottype) + newref = NO + newimage = NO + newfourier = NO + newfilter = NO + newplot = NO + } else + call printf ( + "\nError computing new kernel ...\n") + } + + if (newfilter == YES) { + if (Memr[rg_pstatp(pm,FFT)] != NULL) { + call rg_pfilter (pm) + ncolr = INDEFI + nliner = INDEFI + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, + plottype) + newfilter = NO + newplot = NO + } else + call printf ( + "The kernel fourier spectrum is undefined\n") + } + + } else + call printf ("The objects list is empty\n") + + # Draw a contour plot of the kernel. + case 'k': + if (plotfunc != PM_PKERNEL) + newplot = YES + if (plottype != PM_PCONTOUR) + newplot = YES + plotfunc = PM_PKERNEL + plottype = PM_PCONTOUR + ncolr = (1 + rg_pstati (pm, KNX)) / 2 + nliner = (1 + rg_pstati (pm, KNY)) / 2 + + # Draw a contour plot of the fourier spectrum. + case 'p': + if (plotfunc != PM_PPOWER) + newplot = YES + if (plottype != PM_PCONTOUR) + newplot = YES + plotfunc = PM_PPOWER + plottype = PM_PCONTOUR + ncolr = (1 + rg_pstati (pm, NXFFT)) / 2 + nliner = (1 + rg_pstati (pm, NYFFT)) / 2 + + # Plot a line of the current plot. + case 'x': + if (plottype != PM_PCOL) + newplot = YES + if (plottype == PM_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (plottype == PM_PLINE) { + ncolr = nint (wx) + } + plottype = PM_PCOL + + # Plot a line of the current plot. + case 'y': + if (plottype != PM_PLINE) + newplot = YES + if (plottype == PM_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (plottype == PM_PCOL) { + ncolr = nint (wx) + } + plottype = PM_PLINE + + # Redraw the current plot. + case 'r': + newplot = YES + + # Do nothing gracefully. + default: + ; + + } + + if (newplot == YES) { + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE && + rg_pstati (pm, NREGIONS) <= 0) { + call printf ("Warning: The objects list is empty\n") + } else if (newref == YES || newimage == YES || + newfourier == YES || newfilter == YES) { + call printf ( + "Warning: Convolution kernel should be refit\n") + } else if (rg_pstatp (pm, CONV) != NULL) { + call rg_pplot (gd, pm, ncolr, nliner, plotfunc, plottype) + newplot = NO + } else { + call printf ( + "Warning: The convolution kernel is undefined\n") + } + } + + } + + call sfree (sp) +end + + +define QUERY "[Hit return to continue, n next image, q quit, w quit and update parameters]" + +# RG_PGQVERIFY -- Print a message in the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_pgqverify (task, pm, imk, ch) + +char task[ARB] # task name +pointer pm # pointer to psfmatch structure +pointer imk # pointer to kernel image +int ch # character keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur(), rg_pstati() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + stat = YES + } else if (ch == 'w') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + if (streq ("psfmatch", task)) + call rg_pppars (pm) + stat = YES + } else if (ch == 'n') { + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + + return (stat) +end + + +# RG_PGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_pgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end + + +# RG_PPLOT -- Draw the default plot of the kernel fourier spectrum or the +# kernel itself. + +procedure rg_pplot (gd, pm, col, line, plotfunc, plottype) + +pointer gd #I pointer to the graphics stream +pointer pm #I pointer to the psfmatch structure +int col #I column of cross-correlation function to plot +int line #I line of cross-correlation function to plot +int plotfunc #I the default plot function type +int plottype #I the default plot type + +int nx, ny +pointer sp, title, str, data +int rg_pstati(), strlen() +pointer rg_pstatp() + +begin + if (gd == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the plot title and data. + switch (plotfunc) { + case PM_PPOWER: + call sprintf (Memc[title], SZ_LINE, + "Fourier Spectrum for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, ASFFT) + nx = rg_pstati (pm, NXFFT) + ny = rg_pstati (pm, NYFFT) + case PM_PKERNEL: + call sprintf (Memc[title], SZ_LINE, + "Convolution Kernel for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, CONV) + nx = rg_pstati (pm, KNX) + ny = rg_pstati (pm, KNY) + default: + call sprintf (Memc[title], SZ_LINE, + "Convolution Kernel for Reference: %s Image: %s") + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + data = rg_pstatp (pm, CONV) + nx = rg_pstati (pm, KNX) + nx = rg_pstati (pm, KNY) + } + if (IS_INDEFI(col)) + col = 1 + nx / 2 + if (IS_INDEFI(line)) + line = 1 + ny / 2 + + # Draw the plot. + if (ny == 1) { + switch (plotfunc) { + case PM_PPOWER: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,ASFFT)], + nx, ny, 1) + case PM_PKERNEL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,CONV)], + nx, ny, 1) + default: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (1) + call rg_pcpline (gd, Memc[title], Memr[rg_pstatp(pm,CONV)], + nx, ny, 1) + } + } else { + switch (plottype) { + case PM_PCONTOUR: + call rg_contour (gd, Memc[title], "", Memr[data], nx, ny) + case PM_PLINE: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nLine %d") + call pargi (line) + call rg_pcpline (gd, Memc[title], Memr[data], nx, ny, line) + case PM_PCOL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nColumn %d") + call pargi (col) + call rg_pcpcol (gd, Memc[title], Memr[data], nx, ny, col) + default: + call rg_contour (gd, Memc[title], "", Memr[data], nx, ny) + } + } + + call sfree (sp) +end + + +# RG_PCPLINE -- Plot a line of a 2D function. + +procedure rg_pcpline (gd, title, data, nx, ny, nline) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title for the plot +real data[nx,ARB] #I the input data array +int nx, ny #I dimensions of the input data array +int nline #I the line number + +int i +pointer sp, str, x +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + if (nline < 1 || nline > ny) + return + + # Allocate some working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (x, nx, TY_REAL) + + # Initialize the data. + do i = 1, nx + Memr[x+i-1] = i + call alimr (data[1,nline], nx, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (nx), ymin, ymax) + call glabax (gd, title, "X Lag", "X-Correlation Function") + + # Plot the line profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], data[1,nline], nx) + call gflush (gd) + + call sfree (sp) +end + + +# RG_PCPCOL -- Plot a column of the cross-correlation function. + +procedure rg_pcpcol (gd, title, data, nx, ny, ncol) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title of the column plot +real data[nx,ARB] #I the input data array +int nx, ny #I the dimensions of the input data array +int ncol #I line number + +int i +pointer sp, x, y +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + if (ncol < 1 || ncol > nx) + return + + # Initialize. + call smark (sp) + call salloc (x, ny, TY_REAL) + call salloc (y, ny, TY_REAL) + + # Get the data to be plotted. + do i = 1, ny { + Memr[x+i-1] = i + Memr[y+i-1] = data[ncol,i] + } + call alimr (Memr[y], ny, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (ny), ymin, ymax) + call glabax (gd, title, "Y Lag", "X-Correlation Function") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], Memr[y], ny) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgppars.x b/pkg/images/immatch/src/psfmatch/rgppars.x new file mode 100644 index 00000000..c8d49baa --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgppars.x @@ -0,0 +1,124 @@ +include "psfmatch.h" + +# RG_PGPARS -- Read in the psf matching algorithm parameters. + +procedure rg_pgpars (pm) + +pointer pm #I pointer to psfmatch structure + +int ival +pointer sp, str +bool clgetb() +int clgwrd(), clgeti(), btoi() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the psf matching structure. + call rg_pinit (pm, clgwrd ("convolution", Memc[str], SZ_LINE, + PM_CTYPES)) + + # Define the data and kernel sizes. + ival = clgeti ("dnx") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNX, ival) + ival = clgeti ("dny") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, DNY, ival) + ival = clgeti ("pnx") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNX, ival) + ival = clgeti ("pny") + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_pseti (pm, PNY, ival) + + # Centering parameters. + call rg_pseti (pm, CENTER, btoi (clgetb ("center"))) + + # Background value computation. + call clgstr ("background", Memc[str], SZ_LINE) + call rg_psets (pm, BSTRING, Memc[str]) + call rg_psetr (pm, LOREJECT, clgetr ("loreject")) + call rg_psetr (pm, HIREJECT, clgetr ("hireject")) + call rg_psetr (pm, APODIZE, clgetr ("apodize")) + + # Filtering parameters. + call rg_psetr (pm, UFLUXRATIO, clgetr ("fluxratio")) + call clgstr ("filter", Memc[str], SZ_LINE) + call rg_psets (pm, FSTRING, Memc[str]) + call rg_psetr (pm, SXINNER, clgetr ("sx1")) + call rg_psetr (pm, SXOUTER, clgetr ("sx2")) + call rg_psetr (pm, SYINNER, clgetr ("sy1")) + call rg_psetr (pm, SYOUTER, clgetr ("sy2")) + call rg_pseti (pm, RADSYM, btoi (clgetb ("radsym"))) + call rg_psetr (pm, THRESHOLD, (clgetr ("threshold"))) + + # Normalization parameter. + call rg_psetr (pm, NORMFACTOR, clgetr ("normfactor")) + + #call rg_psetr (pm, PRATIO, clgetr ("pratio")) + + call sfree (sp) +end + + +# RG_PPPARS -- Put the parameters required for the psf matching from +# the cl to the parameter file. + +procedure rg_pppars (pm) + +pointer pm #I pointer to the psf matching structure + +pointer sp, str +bool itob() +int rg_pstati() +real rg_pstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Store the psf data string. + call rg_pstats (pm, PSFDATA, Memc[str], SZ_LINE) + call clpstr ("psf", Memc[str]) + + # Store the size parameters. + call clputi ("dnx", rg_pstati (pm, DNX)) + call clputi ("dny", rg_pstati (pm, DNY)) + call clputi ("pnx", rg_pstati (pm, PNX)) + call clputi ("pny", rg_pstati (pm, PNY)) + + # Store the centering parameters. + call clputb ("center", itob (rg_pstati (pm, CENTER))) + + # Store the background fitting parameters. + call rg_pstats (pm, BSTRING, Memc[str], SZ_LINE) + call clpstr ("background", Memc[str]) + call clputr ("loreject", rg_pstatr (pm, LOREJECT)) + call clputr ("hireject", rg_pstatr (pm, HIREJECT)) + call clputr ("apodize", rg_pstatr (pm, APODIZE)) + + # Store the filtering parameters. + call clputr ("fluxratio", rg_pstatr(pm, UFLUXRATIO)) + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call clpstr ("filter", Memc[str]) + call clputr ("sx1", rg_pstatr (pm, SXINNER)) + call clputr ("sx2", rg_pstatr (pm, SXOUTER)) + call clputr ("sy1", rg_pstatr (pm, SYINNER)) + call clputr ("sy2", rg_pstatr (pm, SYOUTER)) + call clputb ("radsym", itob (rg_pstati (pm, RADSYM))) + call clputr ("threshold", rg_pstatr (pm, THRESHOLD)) + + # Store the normalization parameters. + call clputr ("normfactor", rg_pstatr (pm, NORMFACTOR)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgpregions.x b/pkg/images/immatch/src/psfmatch/rgpregions.x new file mode 100644 index 00000000..c04dcf97 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpregions.x @@ -0,0 +1,464 @@ +include +include +include "psfmatch.h" + +# RG_PREGIONS -- Decoode the regions specification. If the sections +# string is NULL then a default region dnx by dny pixels wide centered +# on the reference image is used. Otherwise the section centers are +# read from the regions string or from the objects list. + +int procedure rg_pregions (list, im, pm, rp, reread) + +int list #I pointer to regions file list +pointer im #I pointer to the image +pointer pm #I pointer to the psfmatch structure +int rp #I region pointer +int reread #I reread the current file + +char fname[SZ_FNAME] +int nregions, fd +int open(), rg_prregions(), rg_pgregions(), fntgfnb() +int rg_pstati() +data fname[1] /EOS/ +errchk open(), fntgfnb(), close() + +begin + if (rp < 1 || rp > MAX_NREGIONS) { + nregions = 0 + } else if (rg_pgregions (im, pm, rp, MAX_NREGIONS) > 0) { + nregions = rg_pstati (pm, NREGIONS) + } else if (list != NULL) { + if (reread == NO) { + iferr { + if (fntgfnb (list, fname, SZ_FNAME) != EOF) { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_prregions (fd, im, pm, rp, MAX_NREGIONS) + call close (fd) + } + } then + nregions = 0 + } else if (fname[1] != EOS) { + iferr { + fd = open (fname, READ_ONLY, TEXT_FILE) + nregions= rg_prregions (fd, im, pm, rp, MAX_NREGIONS) + call close (fd) + } then + nregions = 0 + } + } else + nregions = 0 + + return (nregions) +end + + +# RG_PMKREGIONS -- Create a list of psf objects by selecting objects with +# the image display cursor. + +int procedure rg_pmkregions (fd, im, pm, rp, max_nregions) + +int fd #I the output coordinates file descriptor +pointer im #I pointer to the image +pointer pm #I pointer to the psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, wcs, key, x1, x2, y1, y2 +pointer sp, region, cmd +real x, y, xc, yc +int clgcur(), rg_pstati() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_prealloc (pm, max_nregions) + + nregions = min (rp-1, rg_pstati (pm, NREGIONS)) + while (nregions < max_nregions) { + + # Identify the object. + call printf ("Mark object %d [any key=mark,q=quit]:\n") + call pargi (nregions + 1) + if (clgcur ("icommands", x, y, wcs, key, Memc[cmd], SZ_LINE) == EOF) + break + if (key == 'q') + break + + # Center the object. + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + if (fd != NULL) { + call fprintf (fd, "%0.3f %0.3f\n") + call pargr (xc) + call pargr (yc) + } + + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + + } + + # Reallocate the correct amount of space. + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) { + call rg_prealloc (pm, nregions) + if (fd != NULL) { + call fstats (fd, F_FILENAME, Memc[region], SZ_FNAME) + call rg_psets (pm, PSFDATA, Memc[region]) + } else + call rg_psets (pm, PSFDATA, "") + } else { + call rg_prfree (pm) + call rg_psets (pm, PSFDATA, "") + } + + call sfree (sp) + return (nregions) +end + + +# RG_PRREGIONS -- Procedure to read the regions from a file. + +int procedure rg_prregions (fd, im, pm, rp, max_nregions) + +int fd #I regions file descriptor +pointer im #I pointer to the image +pointer pm #I pointer to psf matching structure +int rp #I pointer to current region +int max_nregions #I maximum number of regions + +int nregions, x1, y1, x2, y2 +pointer sp, line +real x, y, xc, yc +int rg_pstati(), getline() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_prealloc (pm, max_nregions) + + # Decode the regions string. + nregions = min (rp - 1, rg_pstati (pm, NREGIONS)) + while (getline (fd, Memc[line]) != EOF) { + + if (nregions >= max_nregions) + break + + call sscan (Memc[line]) + call gargr (x) + call gargr (y) + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 < 1 || x2 > IM_LEN(im,1) || y1 < 1 || y2 > + IM_LEN(im,2)) + next + + # Add the new region to the list. + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + } + + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) + call rg_prealloc (pm, nregions) + else + call rg_prfree (pm) + + call sfree (sp) + return (nregions) +end + + +# RG_PGREGIONS -- Procedure to compute the column and line limits given +# an x and y position and a default size. + +int procedure rg_pgregions (im, pm, rp, max_nregions) + +pointer im #I pointer to the image +pointer pm #I pointer to psf matching structure +int rp #I pointer to the current region +int max_nregions #I maximum number of regions + +int ncols, nlines, nregions +int x1, x2, y1, y2 +pointer sp, region +real x, y, xc, yc +int rg_pstati(), nscan() +pointer rg_pstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_prealloc (pm, max_nregions) + + # Get the constants. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Decode the center. + call rg_pstats (pm, PSFDATA, Memc[region], SZ_LINE) + nregions = min (rp - 1, rg_pstati (pm, NREGIONS)) + call sscan (Memc[region]) + call gargr (x) + call gargr (y) + + # Compute the data region. + if (nscan() >= 2) { + + # Compute a more accurate center. + if (rg_pstati (pm, CENTER) == YES) { + call rg_pcntr (im, x, y, max (rg_pstati(pm, PNX), + rg_pstati(pm, PNY)), xc, yc) + } else { + xc = x + yc = y + } + + # Compute the data section. + x1 = xc - rg_pstati (pm, DNX) / 2 + x2 = x1 + rg_pstati (pm, DNX) - 1 + if (IM_NDIM(im) == 1) { + y1 = 1 + y2 = 1 + } else { + y1 = yc - rg_pstati (pm, DNY) / 2 + y2 = y1 + rg_pstati (pm, DNY) - 1 + } + + # Make sure that the region is on the image. + if (x1 >= 1 && x2 <= IM_LEN(im,1) && y1 >= 1 && + y2 <= IM_LEN(im,2)) { + Memi[rg_pstatp(pm,RC1)+nregions] = x1 + Memi[rg_pstatp(pm,RC2)+nregions] = x2 + Memi[rg_pstatp(pm,RL1)+nregions] = y1 + Memi[rg_pstatp(pm,RL2)+nregions] = y2 + Memr[rg_pstatp(pm,RZERO)+nregions] = INDEFR + Memr[rg_pstatp(pm,RXSLOPE)+nregions] = INDEFR + Memr[rg_pstatp(pm,RYSLOPE)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + + # Reallocate the correct amount of space. + call rg_pseti (pm, NREGIONS, nregions) + if (nregions > 0) + call rg_prealloc (pm, nregions) + else + call rg_prfree (pm) + + call sfree (sp) + + return (nregions) +end + + +# RG_PCNTR -- Compute star center using MPC algorithm. + +procedure rg_pcntr (im, xstart, ystart, boxsize, xcntr, ycntr) + +pointer im #I pointer to the input image +real xstart, ystart #I initial position +int boxsize #I width of the centering box +real xcntr, ycntr #O computed center + +int x1, x2, y1, y2, half_box +int ncols, nrows, nx, ny, try +real xinit, yinit +pointer bufptr, sp, x_vect, y_vect +int imgs2r() + +begin + # Inialize. + half_box = (boxsize - 1) / 2 + xinit = xstart + ncols = IM_LEN (im, 1) + if (IM_NDIM(im) == 1) { + yinit = 1 + nrows = 1 + } else { + yinit = ystart + nrows = IM_LEN (im, 2) + } + try = 0 + + # Iterate until pixel shifts are less than one. + repeat { + + # Define region to extract. + x1 = max (xinit - half_box, 1.0) +0.5 + x2 = min (xinit + half_box, real(ncols)) +0.5 + y1 = max (yinit - half_box, 1.0) +0.5 + y2 = min (yinit + half_box, real(nrows)) +0.5 + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # Extract region around center + bufptr = imgs2r (im, x1, x2, y1, y2) + + # Compute the new center. + call smark (sp) + if (IM_NDIM(im) == 1) { + call salloc (x_vect, nx, TY_REAL) + call aclrr (Memr[x_vect], nx) + call rg_prowsum (Memr[bufptr], Memr[x_vect], nx, ny) + call rg_pcenter (Memr[x_vect], nx, xcntr) + ycntr = 1 + } else { + call salloc (x_vect, nx, TY_REAL) + call salloc (y_vect, ny, TY_REAL) + call aclrr (Memr[x_vect], nx) + call aclrr (Memr[y_vect], ny) + call rg_prowsum (Memr[bufptr], Memr[x_vect], nx, ny) + call rg_pcolsum (Memr[bufptr], Memr[y_vect], nx, ny) + call rg_pcenter (Memr[x_vect], nx, xcntr) + call rg_pcenter (Memr[y_vect], ny, ycntr) + } + call sfree (sp) + + # Check for INDEF centers. + if (IS_INDEFR(xcntr) || IS_INDEFR(ycntr)) { + xcntr = xinit + ycntr = yinit + break + } + + # Add in offsets + xcntr = xcntr + x1 + ycntr = ycntr + y1 + + try = try + 1 + if (try == 1) { + if ((abs(xcntr-xinit) > 1.0) || (abs(ycntr-yinit) > 1.0)) { + xinit = xcntr + yinit = ycntr + } + } else + break + } +end + + +# RG_PROWSUM -- Sum all rows in a raster. + +procedure rg_prowsum (v, row, nx, ny) + +real v[nx,ny] #I the input subraster +real row[ARB] #O the output row sum +int nx, ny #I the dimensions of the subraster + +int i, j + +begin + do i = 1, ny + do j = 1, nx + row[j] = row[j] + v[j,i] +end + + +# RG_PCOLSUM -- Sum all columns in a raster. + +procedure rg_pcolsum (v, col, nx, ny) + +real v[nx,ny] #I the input subraster +real col[ARB] #O the output column sum +int nx, ny #I the dimensions of the subraster + +int i, j + +begin + do i = 1, ny + do j = 1, nx + col[j] = col[j] + v[i,j] +end + + +# RG_PCENTER -- Compute center of gravity of array. + +procedure rg_pcenter (v, nv, vc) + +real v[ARB] #I the input vector +int nv #I the length of the vector +real vc #O the output center + +int i +real sum1, sum2, sigma, cont + +begin + # Compute first moment + sum1 = 0.0 + sum2 = 0.0 + + call aavgr (v, nv, cont, sigma) + + do i = 1, nv + if (v[i] > cont) { + sum1 = sum1 + (i-1) * (v[i] - cont) + sum2 = sum2 + (v[i] - cont) + } + + # Determine center + if (sum2 == 0.0) + vc = INDEFR + else + vc = sum1 / sum2 +end diff --git a/pkg/images/immatch/src/psfmatch/rgpsfm.x b/pkg/images/immatch/src/psfmatch/rgpsfm.x new file mode 100644 index 00000000..493d48c9 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpsfm.x @@ -0,0 +1,815 @@ +include +include +include "psfmatch.h" + +# RG_PSFM -- Procedure to match the psf functions of two images. + +int procedure rg_psfm (pm, imr, im1, impsf, imk, newref) + +pointer pm #I pointer to psf matching structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to input image +pointer impsf #I pointer to the psf image +pointer imk #I pointer to kernel image +int newref #I new reference image ? + +int stat +int rg_pstati(), rg_pfget(), rg_psfget(), rg_kget() +pointer rg_pstatp() + +begin + # Compute the convolution kernel. + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + + # Compute the kernel using raw image data or the psf image. + if (rg_pstati (pm,CONVOLUTION) == PM_CONIMAGE) { + + # Set the kernel size to the user specified kernel size. + call rg_pseti (pm, KNX, rg_pstati (pm, PNX)) + if (IM_NDIM(imr) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, rg_pstati (pm, PNY)) + + # Compute the FFTS of the input and reference image. + stat = rg_pfget (pm, imr, im1, newref) + + } else { + + # Set the kernel size to the psf image size + call rg_pseti (pm, KNX, IM_LEN (impsf,1)) + if (IM_NDIM(imr) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, IM_LEN(impsf,2)) + + # Compute the FFTS of the input and reference psf images. + stat = rg_psfget (pm, imr, impsf, newref) + } + + # Delete working arrays if an error occurs. + if (stat == ERR) { + if (rg_pstatp (pm, REFFFT) != NULL) + call mfree (rg_pstatp (pm, REFFFT), TY_REAL) + call rg_psetp (pm, REFFFT, NULL) + if (rg_pstatp (pm, IMFFT) != NULL) + call mfree (rg_pstatp (pm, IMFFT), TY_REAL) + call rg_psetp (pm, IMFFT, NULL) + if (rg_pstatp (pm, FFT) != NULL) + call mfree (rg_pstatp (pm, FFT), TY_REAL) + call rg_psetp (pm, FFT, NULL) + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call rg_psetp (pm, CONV, NULL) + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call rg_psetp (pm, ASFFT, NULL) + } + + # Do the filtering in frequency space. + if (rg_pstatp (pm, FFT) != NULL) + call rg_pfilter (pm) + + } else { + + # Set the kernel size. + call rg_pseti (pm, KNX, IM_LEN(imk,1)) + if (IM_NDIM(im1) == 1) + call rg_pseti (pm, KNY, 1) + else + call rg_pseti (pm, KNY, IM_LEN(imk,2)) + + # Read in the convolution kernel. + stat = rg_kget (pm, imk) + + # Delete working arrays if an error occurs. + if (stat == ERR) { + if (rg_pstatp (pm, REFFFT) != NULL) + call mfree (rg_pstatp (pm, REFFFT), TY_REAL) + call rg_psetp (pm, REFFFT, NULL) + if (rg_pstatp (pm, IMFFT) != NULL) + call mfree (rg_pstatp (pm, IMFFT), TY_REAL) + call rg_psetp (pm, IMFFT, NULL) + if (rg_pstatp (pm, FFT) != NULL) + call mfree (rg_pstatp (pm, FFT), TY_REAL) + call rg_psetp (pm, FFT, NULL) + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call rg_psetp (pm, CONV, NULL) + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call rg_psetp (pm, ASFFT, NULL) + } + } + + return (stat) +end + + +# RG_PFGET -- Compute the psfmatching function using Fourier techniques. + +int procedure rg_pfget (pm, imr, im1, newref) + +pointer pm #I pointer to psfmatch structure +pointer imr #I pointer to reference image +pointer im1 #I pointer to input image +int newref #I new reference image ? + +int i, nregions, nrimcols, nrimlines, nrcols, nrlines, nrpcols, nrplines +int nborder, stat, rc1, rc2, rl1, rl2, nxfft, nyfft +pointer sp, str, coeff, dim, rbuf, ibuf, rsum, isum, border +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope, reffft, imfft, fft +real rwtsum, iwtsum, rscale, iscale, rnscale, inscale +bool fp_equalr() +int rg_pstati(), rg_border(), rg_szfft() +pointer rg_pstatp(), rg_pgdata() +real rg_pstatr(), rg_pnsum(), rg_pg1norm(), rg_pg2norm() +real rg_pg10f(), rg_pg20f() + +define nextimage_ 11 + +begin + # Assemble the PSF data by looping over the regions list. + nregions = rg_pstati (pm, NREGIONS) + if (nregions <= 0) + return (ERR) + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF+6, 9), TY_REAL) + call salloc (dim, 2, TY_INT) + + # Get the reference region pointers. + prc1 = rg_pstatp (pm, RC1) + prc2 = rg_pstatp (pm, RC2) + prl1 = rg_pstatp (pm, RL1) + prl2 = rg_pstatp (pm, RL2) + przero = rg_pstatp (pm, RZERO) + prxslope = rg_pstatp (pm, RXSLOPE) + pryslope = rg_pstatp (pm, RYSLOPE) + + # Check to see if the reference / input images are 1D. + nrimcols = IM_LEN(imr,1) + nrpcols = rg_pstati (pm, PNX) + if (IM_NDIM(imr) == 1) { + nrimlines = 1 + nrplines = 1 + } else { + nrimlines = IM_LEN(imr,2) + nrplines = rg_pstati (pm, PNY) + } + + # Initialize + rwtsum = 0.0 + iwtsum = 0.0 + rnscale = INDEFR + inscale = INDEFR + rbuf = NULL + ibuf = NULL + stat = OK + if (newref == YES) + call calloc (rsum, rg_pstati (pm, DNX) * rg_pstati (pm, DNY), + TY_REAL) + call calloc (isum, rg_pstati (pm, DNX) * rg_pstati (pm, DNY), + TY_REAL) + + do i = 1, nregions { + + # Get the reference subraster regions. + rc1 = max (1, min (nrimcols, Memi[prc1+i-1])) + rc2 = min (nrimcols, max (1, Memi[prc2+i-1])) + rl1 = max (1, min (nrimlines, Memi[prl1+i-1])) + rl2 = min (nrimlines, max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Go to next object if reference region is off the image. + if (nrcols < rg_pstati (pm, DNX) || (IM_NDIM(imr) == 2 && + nrlines < rg_pstati(pm, DNY))) { + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference object %d: %s[%d:%d,%d:%d] is off image.\n") + call pargi (i) + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + next + } + + if (newref == YES) { + + # Get the reference data. + rbuf = rg_pgdata (imr, rc1, rc2, rl1, rl2) + + # Do the reference image background subtraction. + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, nrpcols, + nrplines, border) + call rg_pscale (pm, Memr[border], nborder, nrcols, + nrlines, nrpcols, nrplines, rg_pstatr (pm, BVALUER), + Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + + # Subtract the reference background. + call rg_subtract (Memr[rbuf], nrcols, nrlines, + Memr[przero+i-1], Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Apodize the reference image data. + if (rg_pstatr (pm, APODIZE) > 0.0) + call rg_apodize (Memr[rbuf], nrcols, nrlines, + rg_pstatr (pm, APODIZE), YES) + + # Compute the scale factors and accumulate the weighted sums. + rscale = rg_pnsum (Memr[rbuf], nrcols, nrlines, nrpcols, + nrplines) + if (! IS_INDEFR(rscale)) { + if (IS_INDEFR(rnscale)) + rnscale = 1.0 / rscale + } + if (IS_INDEFR(rscale)) + rscale = 1.0 + else + rscale = rscale / rnscale + + call amulkr (Memr[rbuf], rscale, Memr[rbuf], nrcols * + nrlines) + rwtsum = rwtsum + rscale + call aaddr (Memr[rsum], Memr[rbuf], Memr[rsum], nrcols * + nrlines) + + call mfree (rbuf, TY_REAL) + } + + # Get the input image data + ibuf = rg_pgdata (im1, rc1, rc2, rl1, rl2) + + # Compute the zero point, and the x and y slopes of input image. + border = NULL + nborder = rg_border (Memr[ibuf], nrcols, nrlines, nrpcols, + nrplines, border) + call rg_pscale (pm, Memr[border], nborder, nrcols, nrlines, + nrpcols, nrplines, rg_pstatr (pm, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + + # Subtract the background from the input image. + call rg_subtract (Memr[ibuf], nrcols, nrlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_pstatr (pm, APODIZE) > 0.0) + call rg_apodize (Memr[ibuf], nrcols, nrlines, rg_pstatr (pm, + APODIZE), YES) + + # Compute the scale factors and accumulate the weighted sums for + # input image. + iscale = rg_pnsum (Memr[ibuf], nrcols, nrlines, nrpcols, nrplines) + if (! IS_INDEFR(iscale)) { + if (IS_INDEFR(inscale)) + inscale = 1.0 / iscale + } + if (IS_INDEFR(iscale)) + iscale = 1.0 + else + iscale = iscale / inscale + + call amulkr (Memr[ibuf], iscale, Memr[ibuf], nrcols * nrlines) + iwtsum = iwtsum + iscale + call aaddr (Memr[isum], Memr[ibuf], Memr[isum], nrcols * nrlines) + + # Free the individual image buffers. + call mfree (ibuf, TY_REAL) + } + + # Check to see if any data was read. + if (iwtsum <= 0.0) { + stat = ERR + goto nextimage_ + } + + # Normalize the summed buffers by the weights. + if (newref == YES) { + if (! fp_equalr (rwtsum, 0.0)) + call adivkr (Memr[rsum], rwtsum, Memr[rsum], nrcols * nrlines) + } + if (! fp_equalr (iwtsum, 0.0)) + call adivkr (Memr[isum], iwtsum, Memr[isum], nrcols * nrlines) + + # Figure out how big the Fourier transform has to be, given + # the size of the reference subraster, the window size and + # the fact that the FFT must be a power of 2. + + nxfft = rg_szfft (nrcols, 0) + if (nrlines == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, 0) + call rg_pseti (pm, NXFFT, nxfft) + call rg_pseti (pm, NYFFT, nyfft) + + imfft = rg_pstatp (pm, IMFFT) + if (imfft != NULL) + call mfree (imfft, TY_REAL) + call calloc (imfft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, IMFFT, imfft) + + # Allocate space for the fft. + fft = rg_pstatp (pm, FFT) + if (fft != NULL) + call mfree (fft, TY_REAL) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, FFT, fft) + + # Allocate space for the reference and input image ffts + if (newref == YES) { + + reffft = rg_pstatp (pm, REFFFT) + if (reffft != NULL) + call mfree (reffft, TY_REAL) + call calloc (reffft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, REFFFT, reffft) + + # Load the reference image FFT. + call rg_rload (Memr[rsum], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + call mfree (rsum, TY_REAL) + rsum = NULL + + # Load the input image FFT. + call rg_iload (Memr[isum], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + call mfree (isum, TY_REAL) + isum = NULL + + # Shift the data for easy of filtering. + call rg_fshift (Memr[fft], Memr[fft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the reference and input image + # data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[fft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[fft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) { + if (rg_pstati (pm, BACKGRD) == PM_BNONE) + call rg_psetr (pm, FLUXRATIO, rg_pg2norm (Memr[fft], + 2 * nxfft, nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pg20f (Memr[fft], + 2 * nxfft, nyfft)) + } else + call rg_psetr (pm, FLUXRATIO, rg_pstatr (pm, UFLUXRATIO)) + + # Separate the two transforms and compute the division. + call rg_pdivfft (Memr[fft], Memr[reffft], Memr[imfft], Memr[fft], + 2 * nxfft, nyfft) + + } else { + + + # Get the reference image FFT. + reffft = rg_pstatp (pm, REFFFT) + + # Load the input image FFT. + call rg_rload (Memr[isum], nrcols, nrlines, Memr[imfft], nxfft, + nyfft) + call mfree (isum, TY_REAL) + isum = NULL + + # Shift the data for easy of filtering. + call rg_fshift (Memr[imfft], Memr[imfft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the input image data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[imfft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[imfft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) { + if (rg_pstati (pm, BACKGRD) == PM_BNONE) + call rg_psetr (pm, FLUXRATIO, rg_pg1norm (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg1norm (Memr[imfft], 2 * nxfft, + nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pg10f (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg10f (Memr[imfft], 2 * nxfft, + nyfft)) + } else + call rg_psetr (pm, FLUXRATIO, rg_pstatr (pm, UFLUXRATIO)) + + # Divide the two functions. + call adivx (Memr[reffft], Memr[imfft], Memr[fft], nxfft * nyfft) + } + + # Normalize the FFT. + call rg_pnorm (Memr[fft], nxfft, nyfft, rg_pstatr (pm, FLUXRATIO)) + + +nextimage_ + + if (rsum != NULL) + call mfree (rsum, TY_REAL) + if (isum != NULL) + call mfree (isum, TY_REAL) + call sfree (sp) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_PSFGET -- Compute the psfmatching function using Fourier techniques. + +int procedure rg_psfget (pm, imr, impsf, newref) + +pointer pm #I pointer to the psfmatch structure +pointer imr #I pointer to the reference psf +pointer impsf #I pointer to the input image psf +int newref #I new reference image + +int nrcols, nrlines, nxfft, nyfft +pointer sp, dim, rbuf, ibuf, imfft, fft, reffft +int rg_szfft() +pointer rg_pgdata(), rg_pstatp() +real rg_pstatr(), rg_pg2norm(), rg_pg1norm() + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + nrcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrlines = 1 + else + nrlines = IM_LEN(imr,2) + + # Get the psf data. + rbuf = NULL + ibuf = NULL + if (newref == YES) { + call calloc (rbuf, nrcols * nrlines, TY_REAL) + rbuf = rg_pgdata (imr, 1, nrcols, 1, nrlines) + } + call calloc (ibuf, nrcols * nrlines, TY_REAL) + ibuf = rg_pgdata (impsf, 1, nrcols, 1, nrlines) + + # Compute the size for the FFT buffers. + nxfft = rg_szfft (nrcols, 0) + if (nrlines == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, 0) + call rg_pseti (pm, NXFFT, nxfft) + call rg_pseti (pm, NYFFT, nyfft) + + imfft = rg_pstatp (pm, IMFFT) + if (imfft != NULL) + call mfree (imfft, TY_REAL) + call calloc (imfft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, IMFFT, imfft) + + # Allocate space for the fft. + fft = rg_pstatp (pm, FFT) + if (fft != NULL) + call mfree (fft, TY_REAL) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, FFT, fft) + + if (newref == YES) { + + reffft = rg_pstatp (pm, REFFFT) + if (reffft != NULL) + call mfree (reffft, TY_REAL) + call calloc (reffft, 2 * nxfft * nyfft, TY_REAL) + call rg_psetp (pm, REFFFT, reffft) + + # Load the reference image FFT. + call rg_rload (Memr[rbuf], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + + # Load the input image FFT. + call rg_iload (Memr[ibuf], nrcols, nrlines, Memr[fft], nxfft, + nyfft) + + # Shift the data for easy of filtering. + call rg_fshift (Memr[fft], Memr[fft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the reference and input image + # data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[fft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[fft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) + call rg_psetr (pm, FLUXRATIO, rg_pg2norm (Memr[fft], + 2 * nxfft, nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pstatr(pm, UFLUXRATIO)) + + # Separate the two transforms and compute the division. + call rg_pdivfft (Memr[fft], Memr[reffft], Memr[imfft], Memr[fft], + 2 * nxfft, nyfft) + + } else { + + # Get the reference image FFT. + reffft = rg_pstatp (pm, REFFFT) + + # Load the input image FFT. + call rg_rload (Memr[ibuf], nrcols, nrlines, Memr[imfft], nxfft, + nyfft) + + # Shift the data for easy of filtering. + call rg_fshift (Memr[imfft], Memr[imfft], 2 * nxfft, nyfft) + + # Compute the Fourier Transform of the input image data. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (Memr[imfft], Memi[dim], 1, 1) + else + call rg_fourn (Memr[imfft], Memi[dim], 2, 1) + + # Compute the flux ratio between the two data sets. + if (IS_INDEFR(rg_pstatr(pm, UFLUXRATIO))) + call rg_psetr (pm, FLUXRATIO, rg_pg1norm (Memr[reffft], + 2 * nxfft, nyfft) / rg_pg1norm (Memr[imfft], 2 * nxfft, + nyfft)) + else + call rg_psetr (pm, FLUXRATIO, rg_pstatr(pm, UFLUXRATIO)) + + # Divide the two functions. + call adivx (Memr[reffft], Memr[imfft], Memr[fft], nxfft * nyfft) + + } + + # Normalize the FFT. + call rg_pnorm (Memr[fft], nxfft, nyfft, rg_pstatr (pm, FLUXRATIO)) + + # Free the data buffers. + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + + call sfree (sp) + + return (OK) +end + + +# RG_KGET -- Read in the convolution kernel. + +int procedure rg_kget (pm, imk) + +pointer pm #I pointer to the psfmatch structure +pointer imk #I pointer to the kernel image + +int nrlines +pointer conv +pointer rg_pstatp(), rg_pgdata() + +begin + if (IM_NDIM(imk) == 1) + nrlines = 1 + else + nrlines = IM_LEN(imk,2) + conv = rg_pstatp (pm, CONV) + if (conv != NULL) + call mfree (conv, TY_REAL) + conv = rg_pgdata (imk, 1, int(IM_LEN(imk,1)), 1, nrlines) + call rg_psetp (pm, CONV, conv) + + return (OK) +end + + +# RG_PFILTER -- Procedure to filter the FFT in frequency space. + +procedure rg_pfilter (pm) + +pointer pm #I pointer to the psf matching structure + +pointer sp, dim, psfft, conv +real nfactor +int rg_pstati() +pointer rg_pstatp() +real rg_pstatr(), asumr() + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + # Allocate space for the fourier spectrum. + if (rg_pstatp (pm, ASFFT) != NULL) + call mfree (rg_pstatp (pm, ASFFT), TY_REAL) + call calloc (psfft, rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT), + TY_REAL) + call rg_psetp (pm, ASFFT, psfft) + + # Allocate space for the convolution kernel. + if (rg_pstatp (pm, CONV) != NULL) + call mfree (rg_pstatp (pm, CONV), TY_REAL) + call malloc (conv, 2 * rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT), + TY_REAL) + call rg_psetp (pm, CONV, conv) + call amovr (Memr[rg_pstatp(pm,FFT)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati (pm, NXFFT) * rg_pstati (pm, NYFFT)) + +# # Compute the zextend parameter. +# call rg_psetr (pm, THRESHOLD, rg_pstatr (pm, PRATIO) * +# rg_gnorm (Memr[rg_pstatp(pm,IMFFT)], rg_pstati(pm,NXFFT), +# rg_pstati(pm,NYFFT))) + + # Filter the frequency spectrum. + switch (rg_pstati(pm,FILTER)) { + case PM_FCOSBELL: + call rg_pcosbell (Memr[rg_pstatp(pm,CONV)], rg_pstati (pm, NXFFT), + rg_pstati (pm, NYFFT), rg_pstatr (pm, SXINNER), rg_pstatr (pm, + SXOUTER), rg_pstatr (pm, SYINNER), rg_pstatr (pm, SYOUTER), + rg_pstati (pm, RADSYM)) + case PM_FREPLACE: + call rg_preplace (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm, + IMFFT)], rg_pstati (pm, NXFFT), rg_pstati (pm, NYFFT), + rg_pstatr (pm,THRESHOLD), rg_pstatr (pm,FLUXRATIO)) + case PM_FMODEL: + call rg_pgmodel (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm, + IMFFT)], rg_pstati (pm, NXFFT), rg_pstati (pm, NYFFT), + rg_pstatr (pm, THRESHOLD), rg_pstatr (pm, FLUXRATIO)) + default: + ; + } + + # Filter out any values greater than the normalization. + call rg_pnormfilt (Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,NXFFT), + rg_pstati(pm,NYFFT), rg_pstatr (pm, FLUXRATIO)) + + # Compute the fourier spectrum. + call rg_pfourier (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,ASFFT)], + rg_pstati(pm,NXFFT), rg_pstati(pm,NYFFT)) + + Memi[dim] = rg_pstati (pm, NXFFT) + Memi[dim+1] = rg_pstati (pm, NYFFT) + call rg_fshift (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati(pm, NXFFT), rg_pstati(pm, NYFFT)) + call rg_fourn (Memr[rg_pstatp(pm,CONV)], Memi[dim], 2, -1) + call rg_fshift (Memr[rg_pstatp(pm,CONV)], Memr[rg_pstatp(pm,CONV)], + 2 * rg_pstati(pm, NXFFT), rg_pstati(pm, NYFFT)) + call adivkr (Memr[rg_pstatp(pm,CONV)], real (rg_pstati(pm,NXFFT) * + rg_pstati(pm,NYFFT)), Memr[rg_pstatp(pm,CONV)], 2 * rg_pstati(pm, + NXFFT) * rg_pstati(pm,NYFFT)) + + # Unpack the convolution kernel. + call rg_movexr (Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,NXFFT), + rg_pstati(pm,NYFFT), Memr[rg_pstatp(pm,CONV)], rg_pstati(pm,KNX), + rg_pstati(pm,KNY)) + + # Normalize the kernel. + if (! IS_INDEFR(rg_pstatr (pm, NORMFACTOR))) { + nfactor = rg_pstatr (pm, NORMFACTOR) / asumr (Memr[rg_pstatp(pm, + CONV)], rg_pstati (pm, KNX) * rg_pstati(pm,KNY)) + call amulkr (Memr[rg_pstatp (pm,CONV)], nfactor, + Memr[rg_pstatp(pm, CONV)], rg_pstati (pm, KNX) * + rg_pstati (pm, KNY)) + } + + # Reallocate the convolution kernel array + #conv = rg_pstatp (pm, CONV) + #if (conv != NULL) { + #call realloc (conv, rg_pstati(pm, KNX) * rg_pstati(pm, KNY), + #TY_REAL) + #call rg_psetp (pm, CONV, conv) + #} + + call sfree (sp) +end + + +# RG_PGDATA -- Fill a buffer from a specified region of the image. + +pointer procedure rg_pgdata (im, c1, c2, l1, l2) + +pointer im #I pointer to the iraf image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image + +int i, ncols, nlines, npts +pointer ptr, index, buf +pointer imgs1r(), imgs2r() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + index = ptr + do i = l1, l2 { + if (IM_NDIM(im) == 1) + buf = imgs1r (im, c1, c2) + else + buf = imgs2r (im, c1, c2, i, i) + call amovr (Memr[buf], Memr[index], ncols) + index = index + ncols + } + + return (ptr) +end + + +# RG_PNSUM -- Compute the total intensity in the subtracted subraster. + +real procedure rg_pnsum (data, ncols, nlines, nxdata, nydata) + +real data[ncols,nlines] #I the input data subraster +int ncols, nlines #I the size of the input subraster +int nxdata, nydata #I the size of the data region + +int j, wxborder, wyborder, npts +real sum +bool fp_equalr() +real asumr() + +begin + wxborder = (ncols - nxdata) / 2 + wyborder = (nlines - nydata) / 2 + + sum = 0.0 + npts = 0 + do j = 1 + wyborder, nlines - wyborder { + sum = sum + asumr (data[1+wxborder,j], nxdata) + npts = npts + nxdata + } + if (npts <= 0 || fp_equalr (sum, 0.0)) + return (INDEFR) + else + return (sum) +end + + +# RG_PWRITE -- Save the convolution kernel and the fourier spectrum of the +# convolution kernel in an image. + +procedure rg_pwrite (pm, imk, imf) + +pointer pm #I pointer to psf matching structure +pointer imk #I pointer to kernel image +pointer imf #I pointer to fourier spectrum image + +int nx, ny +pointer buf +int rg_pstati() +pointer rg_pstatp(), imps2r() + +begin + # Write out the kernel image. + if (imk != NULL && rg_pstatp(pm, CONV) != NULL) { + nx = rg_pstati (pm, KNX) + ny = rg_pstati (pm, KNY) + IM_NDIM(imk) = 2 + IM_LEN(imk,1) = nx + IM_LEN(imk,2) = ny + IM_PIXTYPE(imk) = TY_REAL + buf = imps2r (imk, 1, nx, 1, ny) + if (rg_pstatp (pm, CONV) != NULL) + call amovr (Memr[rg_pstatp(pm,CONV)], Memr[buf], nx * ny) + else + call amovkr (0.0, Memr[buf], nx * ny) + } + + # Write out the fourier spectrum. + if (imf != NULL && rg_pstatp(pm,ASFFT) != NULL) { + nx = rg_pstati (pm, NXFFT) + ny = rg_pstati (pm, NYFFT) + IM_NDIM(imf) = 2 + IM_LEN(imf,1) = nx + IM_LEN(imf,2) = ny + IM_PIXTYPE(imf) = TY_REAL + buf = imps2r (imf, 1, nx, 1, ny) + if (rg_pstatp (pm, CONV) != NULL) + call amovr (Memr[rg_pstatp(pm,ASFFT)], Memr[buf], nx * ny) + else + call amovkr (0.0, Memr[buf], nx * ny) + } +end + diff --git a/pkg/images/immatch/src/psfmatch/rgpshow.x b/pkg/images/immatch/src/psfmatch/rgpshow.x new file mode 100644 index 00000000..c94349a6 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgpshow.x @@ -0,0 +1,116 @@ +include "psfmatch.h" + +# RG_PSHOW -- Print the PSFMATCH task parameters. + +procedure rg_pshow (pm) + +pointer pm #I pointer to psfmatch structure + +pointer sp, str +bool itob() +int rg_pstati() +real rg_pstatr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call rg_pstats (pm, CSTRING, Memc[str], SZ_FNAME) + call printf ("\nConvolution: %s\n") + call pargstr (Memc[str]) + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, PSFDATA, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_PSFDATA) + call pargstr (Memc[str]) + } else if (rg_pstati (pm, CONVOLUTION) == PM_CONPSF) { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_pstats (pm, PSFIMAGE, Memc[str], SZ_FNAME) + call printf (" input psf: %s\n") + call pargstr (Memc[str]) + call rg_pstats (pm, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" reference psf: %s\n") + call pargstr (Memc[str]) + } else { + call rg_pstats (pm, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } + + call rg_pstats (pm, KERNEL, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_KERNEL) + call pargstr (Memc[str]) + call rg_pstats (pm, OUTIMAGE, Memc[str], SZ_FNAME) + if (Memc[str] != EOS) { + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } + + call printf ("Centering and background fitting\n") + call printf (" %s: %b\n") + call pargstr (KY_CENTER) + call pargb (itob(rg_pstati(pm,CENTER))) + call rg_pstats (pm, BSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_BACKGRD) + call pargstr (Memc[str]) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_pstatr (pm, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_pstatr (pm, HIREJECT)) + call printf (" %s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_pstatr (pm, APODIZE)) + + call printf ("Filtering:\n") + call rg_pstats (pm, FSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + if (rg_pstati(pm,FILTER) == PM_FCOSBELL) { + call printf (" %s: %g %s: %g\n") + call pargstr (KY_SXINNER) + call pargr (rg_pstatr (pm, SXINNER)) + call pargstr (KY_SXOUTER) + call pargr (rg_pstatr (pm, SXOUTER)) + call printf (" %s: %g %s: %g\n") + call pargstr (KY_SYINNER) + call pargr (rg_pstatr (pm, SYINNER)) + call pargstr (KY_SYOUTER) + call pargr (rg_pstatr (pm, SYOUTER)) + call printf (" %s: %b\n") + call pargstr (KY_RADSYM) + call pargb (itob(rg_pstati(pm,RADSYM))) + } else { + call printf (" %s: %g\n") + call pargstr (KY_UFLUXRATIO) + call pargr (rg_pstatr (pm, UFLUXRATIO)) + call printf (" %s: %g\n") + call pargstr (KY_THRESHOLD) + call pargr (rg_pstatr(pm,THRESHOLD)) + } + + call printf ("Normalization\n") + call printf (" %s: %g\n") + call pargstr (KY_NORMFACTOR) + call pargr (rg_pstatr (pm, NORMFACTOR)) + + call printf ("\n") + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/rgptools.x b/pkg/images/immatch/src/psfmatch/rgptools.x new file mode 100644 index 00000000..df36c166 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/rgptools.x @@ -0,0 +1,641 @@ +include "psfmatch.h" + +# RG_PINIT -- Initialize the main psfmatch data structure. + +procedure rg_pinit (pm, cfunc) + +pointer pm #O pointer to psfmatch structure +int cfunc #I mode of computing the convolution function + +begin + call malloc (pm, LEN_PSFSTRUCT, TY_STRUCT) + + # Initialize the pointers. + PM_RC1(pm) = NULL + PM_RC2(pm) = NULL + PM_RL1(pm) = NULL + PM_RL2(pm) = NULL + PM_RZERO(pm) = NULL + PM_RXSLOPE(pm) = NULL + PM_RYSLOPE(pm) = NULL + PM_NREGIONS(pm) = 0 + PM_CNREGION(pm) = 1 + + # Define the background fitting parameters. + PM_CENTER(pm) = DEF_CENTER + PM_BACKGRD(pm) = DEF_BACKGRD + PM_BVALUER(pm) = 0.0 + PM_BVALUE(pm) = 0.0 + call strcpy ("median", PM_BSTRING(pm), SZ_FNAME) + PM_LOREJECT(pm) = DEF_LOREJECT + PM_HIREJECT(pm) = DEF_HIREJECT + PM_APODIZE(pm) = 0.0 + + PM_UFLUXRATIO(pm) = DEF_UFLUXRATIO + PM_FILTER(pm) = DEF_FILTER + call strcpy ("replace", PM_FSTRING(pm), SZ_FNAME) + PM_SXINNER(pm) = DEF_SXINNER + PM_SXOUTER(pm) = DEF_SXOUTER + PM_SYINNER(pm) = DEF_SYINNER + PM_SYOUTER(pm) = DEF_SYOUTER + PM_RADSYM(pm) = DEF_RADSYM + PM_THRESHOLD(pm) = DEF_THRESHOLD + + PM_NORMFACTOR(pm) = DEF_NORMFACTOR + + PM_CONVOLUTION(pm) = cfunc + switch (cfunc) { + case PM_CONIMAGE: + PM_CONVOLUTION(pm) = PM_CONIMAGE + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + case PM_CONPSF: + PM_CONVOLUTION(pm) = PM_CONPSF + call strcpy ("psf", PM_CSTRING(pm), SZ_FNAME) + case PM_CONKERNEL: + PM_CONVOLUTION(pm) = PM_CONKERNEL + call strcpy ("kernel", PM_CSTRING(pm), SZ_FNAME) + default: + PM_CONVOLUTION(pm) = PM_CONIMAGE + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + } + PM_DNX(pm) = DEF_DNX + PM_DNY(pm) = DEF_DNY + PM_PNX(pm) = DEF_PNX + PM_PNY(pm) = DEF_PNY + PM_KNX(pm) = 0 + PM_KNY(pm) = 0 + PM_POWER(pm) = DEF_POWER + + PM_REFFFT(pm) = NULL + PM_IMFFT(pm) = NULL + PM_FFT(pm) = NULL + PM_CONV(pm) = NULL + PM_ASFFT(pm) = NULL + PM_NXFFT(pm) = 0 + PM_NYFFT(pm) = 0 + + # Initialize the strings. + PM_IMAGE(pm) = EOS + PM_REFIMAGE(pm) = EOS + PM_PSFDATA(pm) = EOS + PM_PSFIMAGE(pm) = EOS + PM_OBJLIST(pm) = EOS + PM_KERNEL(pm) = EOS + PM_OUTIMAGE(pm) = EOS + + # Initialize the buffers. + call rg_prinit (pm) +end + + +# RG_PRINIT -- Initialize the regions definition portion of the psf matching +# code fitting structure. + +procedure rg_prinit (pm) + +pointer pm #I pointer to psfmatch structure + +begin + call rg_prfree (pm) + + PM_NREGIONS(pm) = 0 + PM_CNREGION(pm) = 1 + + call malloc (PM_RC1(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RC2(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RL1(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RL2(pm), MAX_NREGIONS, TY_INT) + call malloc (PM_RZERO(pm), MAX_NREGIONS, TY_REAL) + call malloc (PM_RXSLOPE(pm), MAX_NREGIONS, TY_REAL) + call malloc (PM_RYSLOPE(pm), MAX_NREGIONS, TY_REAL) + + call amovki (INDEFI, Memi[PM_RC1(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RC2(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RL1(pm)], MAX_NREGIONS) + call amovki (INDEFI, Memi[PM_RL2(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RZERO(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)], MAX_NREGIONS) +end + + +# RG_PINDEFR -- Re-initialize the background and answers regions portion of +# the psf-matching structure. + +procedure rg_pindefr (pm) + +pointer pm #I pointer to the psfmatch structure + +int nregions +int rg_pstati () + +begin + nregions = rg_pstati (pm, NREGIONS) + + if (nregions > 0) { + call amovkr (INDEFR, Memr[PM_RZERO(pm)], nregions) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)], nregions) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)], nregions) + } +end + + +# RG_PREALLOC -- Reallocate the regions buffers and initialize if necessary. + +procedure rg_prealloc (pm, nregions) + +pointer pm #I pointer to psfmatch structure +int nregions #I number of regions + +int nr +int rg_pstati() + +begin + nr = rg_pstati (pm, NREGIONS) + + call realloc (PM_RC1(pm), nregions, TY_INT) + call realloc (PM_RC2(pm), nregions, TY_INT) + call realloc (PM_RL1(pm), nregions, TY_INT) + call realloc (PM_RL2(pm), nregions, TY_INT) + call realloc (PM_RZERO(pm), nregions, TY_REAL) + call realloc (PM_RXSLOPE(pm), nregions, TY_REAL) + call realloc (PM_RYSLOPE(pm), nregions, TY_REAL) + + call amovki (INDEFI, Memi[PM_RC1(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RC2(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RL1(pm)+nr], nregions - nr) + call amovki (INDEFI, Memi[PM_RL2(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RZERO(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RXSLOPE(pm)+nr], nregions - nr) + call amovkr (INDEFR, Memr[PM_RYSLOPE(pm)+nr], nregions - nr) + #call amovkr (INDEFR, Memr[PM_XSHIFTS(pm)+nr], nregions - nr) + #call amovkr (INDEFR, Memr[PM_YSHIFTS(pm)+nr], nregions - nr) +end + + +# RG_PRFREE -- Free the regions portion of the psfmatch structure. + +procedure rg_prfree (pm) + +pointer pm #I/O pointer to psfmatch structure + +begin + call rg_pseti (pm, NREGIONS, 0) + if (PM_RC1(pm) != NULL) + call mfree (PM_RC1(pm), TY_INT) + PM_RC1(pm) = NULL + if (PM_RC2(pm) != NULL) + call mfree (PM_RC2(pm), TY_INT) + PM_RC2(pm) = NULL + if (PM_RL1(pm) != NULL) + call mfree (PM_RL1(pm), TY_INT) + PM_RL1(pm) = NULL + if (PM_RL2(pm) != NULL) + call mfree (PM_RL2(pm), TY_INT) + PM_RL2(pm) = NULL + if (PM_RZERO(pm) != NULL) + call mfree (PM_RZERO(pm), TY_REAL) + PM_RZERO(pm) = NULL + if (PM_RXSLOPE(pm) != NULL) + call mfree (PM_RXSLOPE(pm), TY_REAL) + PM_RXSLOPE(pm) = NULL + if (PM_RYSLOPE(pm) != NULL) + call mfree (PM_RYSLOPE(pm), TY_REAL) + PM_RYSLOPE(pm) = NULL +end + + +# RG_PFREE -- Free the psfmatch structure. + +procedure rg_pfree (pm) + +pointer pm #I pointer to psfmatch structure + +begin + # Free the region descriptors + call rg_prfree (pm) + + if (PM_REFFFT(pm) != NULL) + call mfree (PM_REFFFT(pm), TY_REAL) + if (PM_IMFFT(pm) != NULL) + call mfree (PM_IMFFT(pm), TY_REAL) + if (PM_FFT(pm) != NULL) + call mfree (PM_FFT(pm), TY_REAL) + if (PM_CONV(pm) != NULL) + call mfree (PM_CONV(pm), TY_REAL) + if (PM_ASFFT(pm) != NULL) + call mfree (PM_ASFFT(pm), TY_REAL) + + call mfree (pm, TY_STRUCT) +end + + +# RG_PSTATI -- Fetch the value of a psfmatch task integer parameter. + +int procedure rg_pstati (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case NREGIONS: + return (PM_NREGIONS(pm)) + case CNREGION: + return (PM_CNREGION(pm)) + case CENTER: + return (PM_CENTER(pm)) + case BACKGRD: + return (PM_BACKGRD(pm)) + case CONVOLUTION: + return (PM_CONVOLUTION(pm)) + case DNX: + return (PM_DNX(pm)) + case DNY: + return (PM_DNY(pm)) + case PNX: + return (PM_PNX(pm)) + case PNY: + return (PM_PNY(pm)) + case KNX: + return (PM_KNX(pm)) + case KNY: + return (PM_KNY(pm)) + case POWER: + return (PM_POWER(pm)) + + case FILTER: + return (PM_FILTER(pm)) + case RADSYM: + return (PM_RADSYM(pm)) + + case NXFFT: + return (PM_NXFFT(pm)) + case NYFFT: + return (PM_NYFFT(pm)) + + default: + call error (0, "RG_PSTATI: Unknown integer parameter.") + } +end + + +# RG_PSTATP -- Fetch the value of a psfmatch task pointer parameter. + +pointer procedure rg_pstatp (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case RC1: + return (PM_RC1(pm)) + case RC2: + return (PM_RC2(pm)) + case RL1: + return (PM_RL1(pm)) + case RL2: + return (PM_RL2(pm)) + case RZERO: + return (PM_RZERO(pm)) + case RXSLOPE: + return (PM_RXSLOPE(pm)) + case RYSLOPE: + return (PM_RYSLOPE(pm)) + case REFFFT: + return (PM_REFFFT(pm)) + case IMFFT: + return (PM_IMFFT(pm)) + case FFT: + return (PM_FFT(pm)) + case CONV: + return (PM_CONV(pm)) + case ASFFT: + return (PM_ASFFT(pm)) + default: + call error (0, "RG_PSTATP: Unknown pointer parameter.") + } +end + + +# RG_PSTATR -- Fetch the value of a psfmath task real parameter. + +real procedure rg_pstatr (pm, param) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched + +begin + switch (param) { + case BVALUER: + return (PM_BVALUER(pm)) + case BVALUE: + return (PM_BVALUE(pm)) + case APODIZE: + return (PM_APODIZE(pm)) + case LOREJECT: + return (PM_LOREJECT(pm)) + case HIREJECT: + return (PM_HIREJECT(pm)) + case UFLUXRATIO: + return (PM_UFLUXRATIO(pm)) + case FLUXRATIO: + return (PM_FLUXRATIO(pm)) + case SXINNER: + return (PM_SXINNER(pm)) + case SXOUTER: + return (PM_SXOUTER(pm)) + case SYINNER: + return (PM_SYINNER(pm)) + case SYOUTER: + return (PM_SYOUTER(pm)) + case THRESHOLD: + return (PM_THRESHOLD(pm)) + case NORMFACTOR: + return (PM_NORMFACTOR(pm)) + default: + call error (0, "RG_PSTATR: Unknown real parameter.") + } +end + + +# RG_PSTATS -- Fetch the value of a psfmatch string string parameter. + +procedure rg_pstats (pm, param, str, maxch) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +char str[ARB] # output string +int maxch # maximum number of characters + +begin + switch (param) { + case BSTRING: + call strcpy (PM_BSTRING(pm), str, maxch) + case CSTRING: + call strcpy (PM_CSTRING(pm), str, maxch) + case FSTRING: + call strcpy (PM_FSTRING(pm), str, maxch) + case IMAGE: + call strcpy (PM_IMAGE(pm), str, maxch) + case REFIMAGE: + call strcpy (PM_REFIMAGE(pm), str, maxch) + case PSFDATA: + call strcpy (PM_PSFDATA(pm), str, maxch) + case PSFIMAGE: + call strcpy (PM_PSFIMAGE(pm), str, maxch) + case OBJLIST: + call strcpy (PM_OBJLIST(pm), str, maxch) + case KERNEL: + call strcpy (PM_KERNEL(pm), str, maxch) + case OUTIMAGE: + call strcpy (PM_OUTIMAGE(pm), str, maxch) + default: + call error (0, "RG_PSTATS: Unknown string parameter.") + } +end + + +# RG_PSETI -- Set the value of a psfmatch task integer parameter. + +procedure rg_pseti (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +int value # value of the integer parameter + +begin + switch (param) { + case NREGIONS: + PM_NREGIONS(pm) = value + case CNREGION: + PM_CNREGION(pm) = value + case CENTER: + PM_CENTER(pm) = value + case BACKGRD: + PM_BACKGRD(pm) = value + switch (value) { + case PM_BNONE: + call strcpy ("none", PM_BSTRING(pm), SZ_FNAME) + case PM_BMEAN: + call strcpy ("mean", PM_BSTRING(pm), SZ_FNAME) + case PM_BMEDIAN: + call strcpy ("median", PM_BSTRING(pm), SZ_FNAME) + case PM_BSLOPE: + call strcpy ("plane", PM_BSTRING(pm), SZ_FNAME) + case PM_BNUMBER: + ; + default: + call strcpy ("none", PM_BSTRING(pm), SZ_FNAME) + } + case CONVOLUTION: + PM_CONVOLUTION(pm) = value + switch (value) { + case PM_CONIMAGE: + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + case PM_CONPSF: + call strcpy ("psf", PM_CSTRING(pm), SZ_FNAME) + case PM_CONKERNEL: + call strcpy ("kernel", PM_CSTRING(pm), SZ_FNAME) + default: + call strcpy ("image", PM_CSTRING(pm), SZ_FNAME) + } + case DNX: + PM_DNX(pm) = value + case DNY: + PM_DNY(pm) = value + case PNX: + PM_PNX(pm) = value + case PNY: + PM_PNY(pm) = value + case KNX: + PM_KNX(pm) = value + case KNY: + PM_KNY(pm) = value + case POWER: + PM_POWER(pm) = value + case RADSYM: + PM_RADSYM(pm) = value + case NXFFT: + PM_NXFFT(pm) = value + case NYFFT: + PM_NYFFT(pm) = value + case FILTER: + PM_FILTER(pm) = value + switch (value) { + case PM_FNONE: + call strcpy ("none", PM_FSTRING(pm), SZ_FNAME) + case PM_FCOSBELL: + call strcpy ("cosbell", PM_FSTRING(pm), SZ_FNAME) + case PM_FREPLACE: + call strcpy ("replace", PM_FSTRING(pm), SZ_FNAME) + case PM_FMODEL: + call strcpy ("model", PM_FSTRING(pm), SZ_FNAME) + default: + call strcpy ("none", PM_FSTRING(pm), SZ_FNAME) + } + default: + call error (0, "RG_PSETI: Unknown integer parameter.") + } +end + + +# RG_PSETP -- Set the value of a psfmatch task pointer parameter. + +procedure rg_psetp (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +pointer value # value of the pointer parameter + +begin + switch (param) { + case RC1: + PM_RC1(pm) = value + case RC2: + PM_RC2(pm) = value + case RL1: + PM_RL1(pm) = value + case RL2: + PM_RL2(pm) = value + case RZERO: + PM_RZERO(pm) = value + case RXSLOPE: + PM_RXSLOPE(pm) = value + case RYSLOPE: + PM_RYSLOPE(pm) = value + case REFFFT: + PM_REFFFT(pm) = value + case IMFFT: + PM_IMFFT(pm) = value + case FFT: + PM_FFT(pm) = value + case CONV: + PM_CONV(pm) = value + case ASFFT: + PM_ASFFT(pm) = value + + default: + call error (0, "RG_PSETP: Unknown pointer parameter.") + } +end + + +# RG_PSETR -- Set the value of a psfmatch task real parameter. + +procedure rg_psetr (pm, param, value) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +real value # real parameter + +begin + switch (param) { + case BVALUER: + PM_BVALUER(pm) = value + case BVALUE: + PM_BVALUE(pm) = value + case LOREJECT: + PM_LOREJECT(pm) = value + case HIREJECT: + PM_HIREJECT(pm) = value + case APODIZE: + PM_APODIZE(pm) = value + case UFLUXRATIO: + PM_UFLUXRATIO(pm) = value + case FLUXRATIO: + PM_FLUXRATIO(pm) = value + case SXINNER: + PM_SXINNER(pm) = value + case SXOUTER: + PM_SXOUTER(pm) = value + case SYINNER: + PM_SYINNER(pm) = value + case SYOUTER: + PM_SYOUTER(pm) = value + case THRESHOLD: + PM_THRESHOLD(pm) = value + case NORMFACTOR: + PM_NORMFACTOR(pm) = value + default: + call error (0, "RG_PSETR: Unknown real parameter.") + } +end + + +# RG_PSETS -- Procedure to set the value of a string parameter. + +procedure rg_psets (pm, param, str) + +pointer pm # pointer to psfmatch structure +int param # parameter to be fetched +char str[ARB] # output string + +int index, ip +pointer sp, temp +real rval +int strdic(), fnldir(), ctor() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + + switch (param) { + case BSTRING: + ip = 1 + index = strdic (str, str, SZ_LINE, PM_BTYPES) + if (index > 0) { + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, index) + } else if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUE, rval) + if (ctor (str, ip, rval) > 0) { + call rg_psetr (pm, BVALUER, rval) + call strcpy (str, PM_BSTRING(pm), SZ_FNAME) + call rg_pseti (pm, BACKGRD, PM_NUMBER) + } else { + call rg_psetr (pm, BVALUE, 0.0) + call rg_psetr (pm, BVALUER, 0.0) + } + } + case CSTRING: + index = strdic (str, str, SZ_LINE, PM_CTYPES) + if (index > 0) { + call strcpy (str, PM_CSTRING(pm), SZ_FNAME) + call rg_pseti (pm, CONVOLUTION, index) + } + case FSTRING: + index = strdic (str, str, SZ_LINE, PM_FTYPES) + if (index > 0) { + call strcpy (str, PM_FSTRING(pm), SZ_FNAME) + call rg_pseti (pm, FILTER, index) + } + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_IMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_IMAGE(pm), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_REFIMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_REFIMAGE(pm), SZ_FNAME) + case PSFDATA: + call strcpy (str, PM_PSFDATA(pm), SZ_FNAME) + case PSFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_PSFIMAGE(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_PSFIMAGE(pm), SZ_FNAME) + case OBJLIST: + call strcpy (str, PM_OBJLIST(pm), SZ_FNAME) + case KERNEL: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], PM_KERNEL(pm), SZ_FNAME) + call strcpy (Memc[temp+index], PM_KERNEL(pm), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, PM_OUTIMAGE(pm), SZ_FNAME) + default: + call error (0, "RG_PSETS: Unknown string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/psfmatch/t_psfmatch.x b/pkg/images/immatch/src/psfmatch/t_psfmatch.x new file mode 100644 index 00000000..182ac286 --- /dev/null +++ b/pkg/images/immatch/src/psfmatch/t_psfmatch.x @@ -0,0 +1,365 @@ +include +include +include "psfmatch.h" + +# T_PSFMATCH -- Match the resolution of an image to that of a reference +# image. + +procedure t_psfmatch () + +pointer image1 # pointer to the input image name +pointer imager # pointer to the reference image name +pointer fpsflist # pointer to the regions list +pointer image2 # pointer to the output image name +pointer kernel # pointer to the kernel image name +pointer pspectra # pointer to the fourier spectra image name +int interactive # interactive mode ? +int verbose # verbose mode ? +int boundary # boundary extension type +real constant # constant for boundary extension + +int list1, listr, psflist, listk, list2 +int nregions, newref, stat +pointer sp, imtemp, str, pm, gd, id, imr, im1, impsf, imk, im2 +bool clgetb() +int imtopen(), imtlen(), imtgetim(), fntopnb(), fntlenb(), clgwrd(), btoi() +int rg_pstati(), rg_ptmpimage(), rg_pregions(), rg_psfm(), rg_pisfm() +pointer gopen(), immap(), rg_pstatp() +real clgetr() +errchk fntopnb(), fntclsb() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (imager, SZ_FNAME, TY_CHAR) + call salloc (fpsflist, SZ_LINE, TY_CHAR) + call salloc (kernel, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (pspectra, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_LINE) + listr = imtopen (Memc[str]) + call clgstr ("psfdata", Memc[fpsflist], SZ_LINE) + call clgstr ("kernel", Memc[str], SZ_LINE) + listk = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + + # Open the psf matching fitting structure. + call rg_pgpars (pm) + + # Will the task run in interactive mode? + if (rg_pstati (pm, CONVOLUTION) == PM_CONKERNEL) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + if (interactive == NO && Memc[fpsflist] == EOS) { + call error (0, "The objects list is empty.") + } else if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + psflist = fntopnb (Memc[fpsflist], NO) + if (fntlenb(psflist) > 0 && imtlen (listr) != fntlenb (psflist)) + call error (0, + "The number of reference images and objects lists is not the same") + } else { + psflist = imtopen (Memc[fpsflist]) + if (imtlen (list1) != imtlen (psflist)) + call error (0, + "The number of input and psf images is not the same") + } + call rg_psets (pm, PSFDATA, Memc[fpsflist]) + } else { + call imtclose (listr) + listr = NULL + psflist = NULL + call rg_psets (pm, PSFDATA, "") + } + + # Compare the lengths of the input and output lists. + if (imtlen(listk) <= 0) { + call imtclose (listk) + listk = NULL + } else if (imtlen (list1) != imtlen (listk)) + call error (0, + "The number of input and kernel images is not the same.") + + if (imtlen (list2) <= 0) { + call imtclose (list2) + list2 = NULL + } else if (imtlen (list1) != imtlen (list2)) + call error (0, + "The number of input and output images are not the same.") + + # Get the boundary extension parameters for the image convolution. + boundary = clgwrd ("boundary", Memc[str], SZ_LINE, + "|constant|nearest|reflect|wrap|") + constant = clgetr ("constant") + + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + imr = NULL + impsf = NULL + + # Do each set of input and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open reference image and the associated objects file + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) { + if (imtgetim (listr, Memc[imager], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[imager], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Reference psf/image must be 1D or 2D") + call rg_psets (pm, REFIMAGE, Memc[imager]) + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) { + nregions = rg_pregions (psflist, imr, pm, 1, NO) + if (nregions <= 0 && interactive == NO) + call error (0, "The objects list is empty.") + call rg_psets (pm, PSFIMAGE, "") + } + newref = YES + } + if (rg_pstati (pm, CONVOLUTION) == PM_CONPSF) { + if (imtgetim (psflist, Memc[str], SZ_FNAME) != EOF) { + impsf = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(impsf) != IM_NDIM(imr)) + call error (0, + "Image and reference psf must have same dimensionality") + if (IM_LEN(impsf,1) != IM_LEN(imr,1)) + call error (0, + "Image and reference psf are not the same size") + if (IM_NDIM(impsf) == 2 && (IM_LEN(impsf,2) != + IM_LEN(imr,2))) + call error (0, + "Image and reference psf are not the same size") + call rg_psets (pm, PSFIMAGE, Memc[str]) + newref = YES + } + } + } else { + imr = NULL + impsf = NULL + call rg_psets (pm, REFIMAGE, "") + call rg_psets (pm, PSFIMAGE, "") + call rg_psets (pm, OBJLIST, "") + newref = NO + } + + # Open the input image. + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input image must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) + call error (0, + "Input and reference images must have same dimensionality") + } + call rg_psets (pm, IMAGE, Memc[image1]) + + # Open the kernel image name. + if (listk != NULL) { + if (imtgetim (listk, Memc[kernel], SZ_FNAME) != EOF) + ; + } else { + if (rg_ptmpimage (Memc[image1], "ker", "ker", Memc[kernel], + SZ_FNAME) == NO) + ; + } + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL) + imk = immap (Memc[kernel], NEW_IMAGE, 0) + else + imk = immap (Memc[kernel], READ_ONLY, 0) + call rg_psets (pm, KERNEL, Memc[kernel]) + + + # Construct the output image name. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = NULL + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = NULL + } + call rg_psets (pm, OUTIMAGE, Memc[image2]) + + # Compute the the psf matching kernel. + if (interactive == YES) { + stat = rg_pisfm (pm, imr, psflist, impsf, im1, imk, NULL, im2, + gd, id) + } else { + if (rg_psfm (pm, imr, im1, impsf, imk, newref) == OK) { + if (verbose == YES) { + call printf ( + "Completed computing/reading kernel %s for image %s\n") + call pargstr (Memc[kernel]) + call pargstr (Memc[image1]) + if (rg_pstati(pm, CONVOLUTION) != PM_CONKERNEL) + call rg_pwrite (pm, imk, NULL) + } + } else { + if (verbose == YES) { + call printf ( + "Error computing/reading kernel %s for image %s\n") + call pargstr (Memc[kernel]) + call pargstr (Memc[image1]) + } + } + stat = NO + } + + # Convolve the image. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + if (rg_pstatp(pm, CONV) != NULL) + call printf ( + "\tComputing matched image %s ...\n") + else + call printf ( + "\tComputing matched image %s ...\n") + call pargstr (Memc[imtemp]) + call pargstr (Memc[kernel]) + } + if (rg_pstatp(pm, CONV) != NULL) + call rg_pconvolve (im1, im2, Memr[rg_pstatp(pm,CONV)], + rg_pstati(pm,KNX), rg_pstati(pm,KNY), boundary, + constant) + } + + # Close up the images. + if (im2 != NULL) { + call imunmap (im2) + if (rg_pstatp(pm, CONV) == NULL) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + if (impsf != NULL) + call imunmap (impsf) + if (imk != NULL) { + call imunmap (imk) + if (rg_pstati (pm, CONVOLUTION) != PM_CONKERNEL && + rg_pstatp(pm, CONV) == NULL) + call imdelete (Memc[kernel]) + } + call imunmap (im1) + + if (stat == YES) + break + newref = NO + } + + # Close up the lists. + if (imr != NULL) + call imunmap (imr) + + if (list2 != NULL) + call imtclose (list2) + if (listk != NULL) + call imtclose (listk) + if (psflist != NULL) { + if (rg_pstati (pm, CONVOLUTION) == PM_CONIMAGE) + call fntclsb (psflist) + else + call imtclose (psflist) + } + if (listr != NULL) + call imtclose (listr) + call imtclose (list1) + + call rg_pfree (pm) + + # Close up te graphics and the display. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + call sfree (sp) +end + + +# RG_PTMPIMAGE -- Generate either a permanent image name using a user specified +# prefix or temporary image name using a default prefix. Return NO if the +# image is temporary or YES if it is permanent. + +int procedure rg_ptmpimage (image, prefix, tmp, name, maxch) + +char image[ARB] #I image name +char prefix[ARB] #I user supplied prefix +char tmp[ARB] #I user supplied temporary root +char name[ARB] #O output name +int maxch #I max number of chars + +int npref, ndir +int fnldir(), rg_pimroot(), strlen() + +begin + npref = strlen (prefix) + ndir = fnldir (prefix, name, maxch) + if (npref == ndir) { + call mktemp (tmp, name[ndir+1], maxch) + return (NO) + } else { + call strcpy (prefix, name, npref) + if (rg_pimroot (image, name[npref+1], maxch) <= 0) + ; + return (YES) + } +end + + +# RG_PIMROOT -- Fetch the root image name minus the directory specification +# and the section notation. The length of the root name is returned. + +int procedure rg_pimroot (image, root, maxch) + +char image[ARB] #I image specification +char root[ARB] #O rootname +int maxch #I maximum number of characters + +int nchars +pointer sp, str +int fnldir(), strlen() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + call imgimage (image, root, maxch) + nchars = fnldir (root, Memc[str], maxch) + call strcpy (root[nchars+1], root, maxch) + + call sfree (sp) + return (strlen (root)) +end diff --git a/pkg/images/immatch/src/wcsmatch/mkpkg b/pkg/images/immatch/src/wcsmatch/mkpkg new file mode 100644 index 00000000..638ee1e8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/mkpkg @@ -0,0 +1,14 @@ +# Make the SKYXYMATCH / WCSXYMATCH / WCSCOPY tasks + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgmatchio.x wcsxymatch.h + t_skyxymatch.x \ + wcsxymatch.h + t_wcscopy.x + t_wcsxymatch.x wcsxymatch.h + ; diff --git a/pkg/images/immatch/src/wcsmatch/rgmatchio.x b/pkg/images/immatch/src/wcsmatch/rgmatchio.x new file mode 100644 index 00000000..1a0de167 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/rgmatchio.x @@ -0,0 +1,77 @@ +include "wcsxymatch.h" + +define DEF_BUFSIZE 200 + +# RG_RDXY -- Read in the x and y coordinates from a file. + +int procedure rg_rdxy (fd, x, y, wcs, xcolumn, ycolumn, xunits, yunits) + +int fd #I the input file descriptor +pointer x #U pointer to the x coordinates +pointer y #U pointer to the y coordinates +int wcs #I the world coordinate system +int xcolumn #I column containing the x coordinate +int ycolumn #I column containing the y coordinate +int xunits #I the x coordinate units +int yunits #I the y coordinate units + +double xval, yval +int i, ip, bufsize, maxcols, npts +pointer sp, str +int fscan(), nscan(), ctod() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + bufsize = DEF_BUFSIZE + call malloc (x, bufsize, TY_DOUBLE) + call malloc (y, bufsize, TY_DOUBLE) + maxcols = max (xcolumn, ycolumn) + + npts = 0 + while (fscan(fd) != EOF) { + + xval = INDEFD + yval = INDEFD + do i = 1, maxcols { + call gargwrd (Memc[str], SZ_FNAME) + if (i != nscan()) + break + ip = 1 + if (i == xcolumn) { + if (ctod (Memc[str], ip, xval) <= 0) + xval = INDEFD + } else if (i == ycolumn) { + if (ctod (Memc[str], ip, yval) <= 0) + yval = INDEFD + } + } + if (IS_INDEFD(xval) || IS_INDEFD(yval)) + next + + Memd[x+npts] = xval + Memd[y+npts] = yval + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + DEF_BUFSIZE + call realloc (x, bufsize, TY_DOUBLE) + call realloc (y, bufsize, TY_DOUBLE) + } + } + + # Convert the coordinates if necessary. + switch (wcs) { + case RG_WORLD: + if (xunits == RG_UHOURS) + call amulkd (Memd[x], 15.0d0, Memd[x], npts) + if (yunits == RG_UHOURS) + call amulkd (Memd[y], 15.0d0, Memd[y], npts) + default: + ; + } + + call sfree (sp) + + return (npts) +end diff --git a/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x b/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x new file mode 100644 index 00000000..533d36a8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_skyxymatch.x @@ -0,0 +1,690 @@ +include +include +include +include +include +include "wcsxymatch.h" + +# T_SKYXYMATCH -- Compute a list of the tie points required to register an +# image to a reference image using WCS information in the image headers and +# the celestial coordinate transformation routines. + +procedure t_skyxymatch() + +bool verbose +double xmin, xmax, ymin, ymax, x1, x2, y1, y2 +int ilist, rlist, olist, clist, cfd, ofd +int nx, ny, wcs, min_sigdigits, xcolumn, ycolumn, xunits, yunits +int rstat, stat, npts +pointer sp, refimage, image, xformat, yformat, rxformat, ryformat +pointer rwxformat, rwyformat, txformat, tyformat, twxformat, twyformat, str +pointer imr, im, mwr, mw, coor, coo, ctr, ct +pointer rxl, ryl, rxw, ryw, trxw, tryw, ixl, iyl + +bool clgetb(), streq() +double clgetd() +int imtopen(), fntopnb(), clgeti(), clgwrd(), strdic(), imtlen() +int fntlenb(), imtgetim(), fntgfnb(), open(), mw_stati(), sk_decim() +int rg_rdxy(), rg_xytoxy(), sk_stati() +pointer immap() +errchk mw_gwattrs() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (rwxformat, SZ_FNAME, TY_CHAR) + call salloc (rwyformat, SZ_FNAME, TY_CHAR) + call salloc (rxformat, SZ_FNAME, TY_CHAR) + call salloc (ryformat, SZ_FNAME, TY_CHAR) + call salloc (twxformat, SZ_FNAME, TY_CHAR) + call salloc (twyformat, SZ_FNAME, TY_CHAR) + call salloc (txformat, SZ_FNAME, TY_CHAR) + call salloc (tyformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the input image and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + olist = fntopnb (Memc[str], NO) + + # Determine the source of the input coordinates. + call clgstr ("coords", Memc[str], SZ_FNAME) + if (streq (Memc[str], "grid")) { + clist = NULL + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + } else { + clist = fntopnb (Memc[str], NO) + xmin = INDEFD + xmax = INDEFD + ymin = INDEFD + ymax = INDEFD + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xunits", Memc[str], SZ_FNAME) + xunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (xunits <= 0) + xunits = RG_UNATIVE + call clgstr ("yunits", Memc[str], SZ_FNAME) + yunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (yunits <= 0) + yunits = RG_UNATIVE + } + + # Get the output coordinate formatting information. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + call clgstr ("rwxformat", Memc[rxformat], SZ_FNAME) + call clgstr ("rwyformat", Memc[ryformat], SZ_FNAME) + call clgstr ("wxformat", Memc[txformat], SZ_FNAME) + call clgstr ("wyformat", Memc[tyformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get remaining parameters. + verbose = clgetb ("verbose") + + # Check the formatting of the reference and input logical coordinates. + if (Memc[xformat] == EOS) { + call sprintf (Memc[xformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + if (Memc[yformat] == EOS) { + call sprintf (Memc[yformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Check the output coordinate file length. + if (fntlenb(olist) > 1 && fntlenb(olist) != imtlen(ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + + # Check the reference coordinate list length. + if (clist != NULL) { + if (fntlenb (clist) != imtlen (rlist)) + call error (0, + "The number of reference coords files and images are not the same") + } + + # Initialize the reference image and coordinate list pointers. + imr = NULL + cfd = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (trxw, TY_DOUBLE) + call mfree (tryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + if (coor != NULL) + #call mfree (coor, TY_STRUCT) + call sk_close (coor) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "The reference image must be 1D or 2D") + + # Open the reference image wcs. + rstat = sk_decim (imr, "logical", mwr, coor) + + # Check that the wcs dimensions are rational. + if (mwr != NULL) { + if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr) || + mw_stati (mwr, MW_NDIM) != IM_NDIM(imr)) { + call mw_close (mwr) + mwr = NULL + } + } + + # Compute the x limits of the logical reference coordinates. + if (IS_INDEFD(xmin)) + x1 = 1.0d0 + else + x1 = max (1.0d0, min (xmin, double(IM_LEN(imr,1)))) + if (IS_INDEFD(xmax)) + x2 = double(IM_LEN(imr,1)) + else + x2 = max (1.0d0, min (xmax, double(IM_LEN(imr,1)))) + + # Compute the y limits of the logical reference coordinates. + if (IM_NDIM(imr) == 1) + y1 = 1.0d0 + else if (IS_INDEFD(ymin)) + y1 = 1.0d0 + else + y1 = max (1.0d0, min (ymin, double(IM_LEN(imr,2)))) + if (IM_NDIM(imr) == 1) + y2 = 1.0d0 + else if (IS_INDEFD(ymax)) + y2 = double(IM_LEN(imr,2)) + else + y2 = max (1.0d0, min (ymax, double(IM_LEN(imr,2)))) + + # Compute the reference logical and world coordinates. + if (clist != NULL) { + + if (cfd != NULL) + call close (cfd) + + if (fntgfnb (clist, Memc[str], SZ_FNAME) != EOF) { + cfd = open (Memc[str], READ_ONLY, TEXT_FILE) + npts = rg_rdxy (cfd, rxw, ryw, wcs, xcolumn, ycolumn, + xunits, yunits) + call malloc (trxw, npts, TY_DOUBLE) + call malloc (tryw, npts, TY_DOUBLE) + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "world", "logical", + 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "physical", + "logical", 1, 2) + } + + } else { + + if (IM_NDIM(imr) == 1) + npts = nx + else + npts = nx * ny + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (rxw, npts, TY_DOUBLE) + call malloc (ryw, npts, TY_DOUBLE) + call malloc (trxw, npts, TY_DOUBLE) + call malloc (tryw, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, x1, x2, + y1, y2) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, x1, x2, + y1, y2) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "world", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "physical", 1, 2) + + } + } + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) > 2) + call error (0, "The input image must be 1D or 2D") + if (IM_NDIM(im) != IM_NDIM(imr)) + call error (0, + "The input image must have same dimensionality as reference image") + + # Open the input wcs. + stat = sk_decim (im, "logical", mw, coo) + if (mw != NULL) { + if (mw_stati(mw, MW_NPHYSDIM) < IM_NDIM(im) || + mw_stati (mw, MW_NDIM) != IM_NDIM(im)) { + call mw_close (mw) + mw = NULL + } + } + + # Open the output file. + if (fntgfnb (olist, Memc[str], SZ_FNAME) != EOF) + ofd = open (Memc[str], NEW_FILE, TEXT_FILE) + + # Print information about the reference and input coordinate + # systems and the reference and input files to the output + # file + if (ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + if (streq (Memc[str], "STDOUT") || ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + call fprintf (ofd, "\n") + call fprintf (ofd, + "# Reference image: %s Input image: %s\n# Coords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call fprintf (ofd, " Wcs: logical\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call fprintf (ofd, " Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + if (rstat == ERR) + call fprintf (ofd, + "# Error decoding the reference coordinate system\n") + call sk_iiwrite (ofd, "Refsystem", Memc[refimage], mwr, coor) + if (stat == ERR) + call fprintf (ofd, + "# Error decoding the input coordinate system\n") + call sk_iiwrite (ofd, "Insystem", Memc[image], mw, coo) + + # Print information about the reference and input coordinate + # systems and the reference and input files to the standard + # output. + if (verbose && ofd != STDOUT) { + call printf ("\n") + call printf ( + "Reference image: %s Input image: %s\n Coords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call printf (" Wcs: logical\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + if (rstat == ERR) + call printf ( + "Error decoding the rference coordinate system\n") + call sk_iiprint ("Refsystem", Memc[refimage], mwr, coor) + if (stat == ERR) + call printf ( + "Error decoding the input coordinate system\n") + call sk_iiprint ("Insystem", Memc[image], mw, coo) + call printf ("\n") + } + + # Set the reference and input coordinate formats. + if (Memc[rxformat] == EOS) + call rg_ssetfmt (mwr, wcs, sk_stati(coor, S_XLAX), + min_sigdigits, Memc[rwxformat], SZ_FNAME) + else + call strcpy (Memc[rxformat], Memc[rwxformat], SZ_FNAME) + + if (Memc[txformat] == EOS) + call rg_ssetfmt (mw, wcs, sk_stati(coo, S_XLAX), + min_sigdigits, Memc[twxformat], SZ_FNAME) + else + call strcpy (Memc[txformat], Memc[twxformat], SZ_FNAME) + if (Memc[ryformat] == EOS) + call rg_ssetfmt (mwr, wcs, sk_stati(coor, S_YLAX), + min_sigdigits, Memc[rwyformat], SZ_FNAME) + else + call strcpy (Memc[ryformat], Memc[rwyformat], SZ_FNAME) + if (Memc[tyformat] == EOS) + call rg_ssetfmt (mw, wcs, sk_stati(coo, S_YLAX), + min_sigdigits, Memc[twyformat], SZ_FNAME) + else + call strcpy (Memc[tyformat], Memc[twyformat], SZ_FNAME) + + + # Compute the output coordinates issuing a warning if the + # axes types are not compatable. + if (mwr == NULL || rstat == ERR) { + call fprintf (ofd, + "# \tWarning: error decoding reference image wcs\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: error decoding reference image wcs\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + call amovd (Memd[rxl], Memd[trxw], npts) + call amovd (Memd[ryl], Memd[tryw], npts) + } + ct = NULL + } else if (ctr == NULL) { + call fprintf (ofd, "# \tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + call amovd (Memd[rxl], Memd[trxw], npts) + call amovd (Memd[ryl], Memd[tryw], npts) + } + ct = NULL + } else if (mw == NULL || stat == ERR) { + call fprintf (ofd, + "# \tWarning: error decoding input image wcs\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: error decoding input image wcs\n") + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + call amovd (Memd[rxw], Memd[trxw], npts) + call amovd (Memd[ryw], Memd[tryw], npts) + ct = NULL + } else { + # Check axis status. + if (wcs == RG_PHYSICAL) { + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "physical", "logical", 1, 2) + call amovd (Memd[rxw], Memd[trxw], npts) + call amovd (Memd[ryw], Memd[tryw], npts) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image physical -> \ +logical transform\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: Unable to compute image physical \ +-> logical transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } else { + call rg_lltransform (coor, coo, Memd[rxw], Memd[ryw], + Memd[trxw], Memd[tryw], npts) + if ((sk_stati (coor, S_PLNGAX) < sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) < + sk_stati(coo, S_PLATAX))) + ct = rg_xytoxy (mw, Memd[trxw], Memd[tryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + else if ((sk_stati (coor, S_PLNGAX) > sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) > + sk_stati(coo, S_PLATAX))) + ct = rg_xytoxy (mw, Memd[trxw], Memd[tryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + else + ct = rg_xytoxy (mw, Memd[tryw], Memd[trxw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image world -> \ +logical transform\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: Unable to compute image world -> \ +logical transform\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } + } + + # Write out the results. + if ((sk_stati (coor, S_PLNGAX) < sk_stati(coor, S_PLATAX)) && + (sk_stati (coo,S_PLNGAX) < sk_stati(coo, S_PLATAX))) + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[trxw], Memd[tryw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + else if ((sk_stati (coor, S_PLNGAX) > sk_stati(coor, + S_PLATAX)) && (sk_stati (coo,S_PLNGAX) > sk_stati(coo, + S_PLATAX))) + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[trxw], Memd[tryw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + else + call rg_swcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], Memd[tryw], Memd[trxw], + npts, Memc[xformat], Memc[yformat], Memc[rwxformat], + Memc[rwyformat], Memc[twxformat], Memc[twyformat]) + + # Close the input image and its wcs. + if (mw != NULL) + call mw_close (mw) + if (coo != NULL) + #call mfree (coo, TY_STRUCT) + call sk_close (coo) + call imunmap (im) + + # Close the output coordinate file if it is not going to + # be appended to. + if (fntlenb(olist) == imtlen(ilist)) + call close (ofd) + } + + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (trxw, TY_DOUBLE) + call mfree (tryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + if (coor != NULL) + #call mfree (coor, TY_STRUCT) + call sk_close (coor) + call imunmap (imr) + } + if (cfd != NULL) + call close (cfd) + if (fntlenb(olist) < imtlen(ilist)) + call close (ofd) + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + if (olist != NULL) + call fntclsb (olist) + if (clist != NULL) + call fntclsb (clist) + + call sfree (sp) +end + + +# RG_SSETFMT -- Procedure to set the appropriate default format. + +procedure rg_ssetfmt (mw, wcs, laxno, min_sigdigits, wformat, maxch) + +pointer mw #I pointer to the image wcs +int wcs #I the input wcs type +int laxno #I the physical axis number +int min_sigdigits #I the minmum number of significant digits +char wformat[ARB] #O the output format string +int maxch #I the maximum size of the output format string + +pointer sp, str +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + if (mw == NULL) { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else if (wcs == RG_PHYSICAL) { + call strcpy ("%10.3f", wformat, maxch) + } else { + iferr { + call mw_gwattrs (mw, laxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mw, laxno, "axtype", Memc[str], SZ_FNAME) + } then { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else { + if (streq (Memc[str], "ra")) + call strcpy ("%12.2H", wformat, maxch) + else if (streq (Memc[str], "dec")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lon")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lat")) + call strcpy ("%11.1h", wformat, maxch) + else { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + } + } + } + + call sfree (sp) +end + + +# RG_SWCOORDS -- Write out the reference and input logical coordinates of the +# tie points and the reference world coordinates. + +procedure rg_swcoords (ofd, xref, yref, xin, yin, wxref, wyref, twxref, twyref, + npts, xformat, yformat, wxformat, wyformat, twxformat, twyformat) + +int ofd #I the output file descriptor +double xref[ARB] #I the reference logical x coordinates +double yref[ARB] #I the reference logical y coordinates +double xin[ARB] #I the input logical x coordinates +double yin[ARB] #I the input logical y coordinates +double wxref[ARB] #I the reference world x coordinates +double wyref[ARB] #I the reference world y coordinates +double twxref[ARB] #I the input world x coordinates +double twyref[ARB] #I the input world y coordinates +int npts #I the number of input points +char xformat[ARB] #I the logical x coordinates format +char yformat[ARB] #I the logical y coordinates format +char wxformat[ARB] #I the reference world x coordinates format +char wyformat[ARB] #I the reference world y coordinates format +char twxformat[ARB] #I the input world x coordinates format +char twyformat[ARB] #I the input world y coordinates format + +int i +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Write the column descriptions. + call fprintf (ofd, + "# \tColumn 1: reference logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 2: reference logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 3: input logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 4: input logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 5: reference world x coordinate\n") + call fprintf (ofd, + "# \tColumn 6: reference world y coordinate\n") + call fprintf (ofd, + "# \tColumn 7: input world x coordinate\n") + call fprintf (ofd, + "# \tColumn 8: input world y coordinate\n") + call fprintf (ofd, "\n") + + call sprintf (Memc[fmtstr], SZ_LINE, + "%s %s %s %s %s %s %s %s\n") + call pargstr (xformat) + call pargstr (yformat) + call pargstr (xformat) + call pargstr (yformat) + call pargstr (wxformat) + call pargstr (wyformat) + call pargstr (twxformat) + call pargstr (twyformat) + + do i = 1, npts { + call fprintf (ofd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + call pargd (wxref[i]) + call pargd (wyref[i]) + call pargd (twxref[i]) + call pargd (twyref[i]) + } + + call sfree (sp) +end + diff --git a/pkg/images/immatch/src/wcsmatch/t_wcscopy.x b/pkg/images/immatch/src/wcsmatch/t_wcscopy.x new file mode 100644 index 00000000..6d15e5c8 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_wcscopy.x @@ -0,0 +1,199 @@ +include +include + +# T_WCSCOPY -- Copy the world coordinate system of a reference image to +# the world coordinate system of an input image. + +procedure t_wcscopy() + +bool verbose +int ilist, rlist +pointer sp, image, refimage, value, str, imr, mwr, im +real rval +double dval +bool clgetb() +int imtopen(), imtlen(), imtgetim() +#int mw_stati(), rg_samesize() +pointer immap(), mw_openim() +real imgetr() +double imgetd() +errchk mw_openim(), imgstr(), imgetr(), imgetd(), imdelf() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the input image and reference image lists. + call clgstr ("images", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("refimages", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + verbose = clgetb ("verbose") + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Initialize the reference image and coordinate list pointers. + imr = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + + # Open the reference image wcs. + iferr (mwr = mw_openim (imr)) + mwr = NULL + + # Check that the wcs dimensions are rational. +# if (mwr != NULL) { +# if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr)) { +# call mw_close (mwr) +# mwr = NULL +# } +# } + } + + # Print message about progress of task + if (verbose) { + call printf ("Copying wcs from image %s to image %s\n") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + } + + # Remove any image section and open the input image. + call imgimage (Memc[image], Memc[image], SZ_FNAME) + iferr (im = immap (Memc[image], READ_WRITE, 0)) { + im = immap (Memc[image], NEW_IMAGE, 0) + IM_NDIM(im) = 0 + } + + # Test for valid wcs. + if (mwr == NULL) { + if (verbose) { + call printf ( + "\tError: cannot read wcs for reference image %s\n") + call pargstr (Memc[refimage]) + } +# } else if (IM_NDIM(im) != IM_NDIM(imr)) { +# if (verbose) { +# call printf ( +# "\tError: %s and %s have different number of dimensions\n") +# call pargstr (Memc[image]) +# call pargstr (Memc[refimage]) +# } + } else { +# if (rg_samesize (imr, im) == NO) { +# if (verbose) { +# call printf ( +# "\tWarning: images %s and %s have different sizes\n") +# call pargstr (Memc[image]) +# call pargstr (Memc[refimage]) +# } +# } + #mw = mw_open (NULL, mw_stati (mwr,MW_NPHYSDIM)) + #call mw_loadim (mw, imr) + #call mw_saveim (mw, im) + #call mw_close (mw) + call mw_saveim (mwr, im) + + # Copy the RADECSYS keyword to the input image header. + ifnoerr { + call imgstr (imr, "RADECSYS", Memc[value], SZ_FNAME) + } then { + call imastr (im, "RADECSYS", Memc[value]) + } else { + iferr (call imdelf (im, "RADECSYS")) + ; + } + + # Copy the EQUINOX or EPOCH keyword to the input image header + # EQUINOX keyword. + ifnoerr { + rval = imgetr (imr, "EQUINOX") + } then { + call imaddr (im, "EQUINOX", rval) + iferr (call imdelf (im, "EPOCH")) + ; + } else { + ifnoerr { + rval = imgetr (imr, "EPOCH") + } then { + call imaddr (im, "EQUINOX", rval) + iferr (call imdelf (im, "EPOCH")) + ; + } else { + iferr (call imdelf (im, "EQUINOX")) + ; + iferr (call imdelf (im, "EPOCH")) + ; + } + } + + # Copy the MJD-WCSkeyword to the input image header. + ifnoerr { + dval = imgetd (imr, "MJD-WCS") + } then { + call imaddd (im, "MJD-WCS", dval) + } else { + iferr (call imdelf (im, "MJD-WCS")) + ; + } + } + + # Close the input image. + call imunmap (im) + + } + + if (imr != NULL) { + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + + call sfree (sp) +end + + +# RG_SAMESIZE -- Determine whether two images of the same dimension are +# the same size. + +int procedure rg_samesize (im1, im2) + +pointer im1 #I the first image descriptor +pointer im2 #I the second image descriptor + +int i, stat + +begin + stat = YES + do i = 1, IM_NDIM(im1) { + if (IM_LEN(im1,i) != IM_LEN(im2,i)) + return (NO) + } + return (stat) +end diff --git a/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x b/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x new file mode 100644 index 00000000..503bc7f3 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/t_wcsxymatch.x @@ -0,0 +1,787 @@ +include +include +include +include "wcsxymatch.h" + +# T_WCSXYMATCH -- Compute a list of the tie points required to register an +# image to a reference image using WCS information in the image headers. + +procedure t_wcsxymatch() + +bool verbose, transpose +double xmin, xmax, ymin, ymax, x1, x2, y1, y2 +int ilist, rlist, olist, clist, cfd, ofd +int nx, ny, npts, wcs, xcolumn, ycolumn +int xunits, yunits, min_sigdigits, axstat, projstat +pointer sp, refimage, image, xformat, yformat, rxformat, ryformat +pointer wxformat, wyformat, str, paxno, rlaxno, laxno +pointer im, imr, mw, mwr, rxl, ryl, rxw, ryw, ixl, iyl, ctr, ct + +bool clgetb(), streq() +double clgetd() +int imtopen(), fntopnb(), imtlen(), fntlenb(), imtgetim(), open(), clgeti() +int clgwrd(), rg_rdxy(), fntgfnb(), rg_axstat(), rg_projstat(), mw_stati() +int strdic() +pointer immap(), mw_openim(), rg_xytoxy() +errchk mw_openim(), mw_gwattrs() + +begin + # Get some temporary working space. + call smark (sp) + call salloc (refimage, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (xformat, SZ_FNAME, TY_CHAR) + call salloc (yformat, SZ_FNAME, TY_CHAR) + call salloc (wxformat, SZ_FNAME, TY_CHAR) + call salloc (wyformat, SZ_FNAME, TY_CHAR) + call salloc (rxformat, SZ_FNAME, TY_CHAR) + call salloc (ryformat, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + call salloc (paxno, IM_MAXDIM, TY_INT) + call salloc (rlaxno, IM_MAXDIM, TY_INT) + call salloc (laxno, IM_MAXDIM, TY_INT) + + # Get the input image and output file lists. + call clgstr ("input", Memc[str], SZ_FNAME) + ilist = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_FNAME) + rlist = imtopen (Memc[str]) + call clgstr ("output", Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call strcpy ("STDOUT", Memc[str], SZ_FNAME) + olist = fntopnb (Memc[str], NO) + + # Determine the source of the input coordinates. + call clgstr ("coords", Memc[str], SZ_FNAME) + if (streq (Memc[str], "grid")) { + clist = NULL + xmin = clgetd ("xmin") + xmax = clgetd ("xmax") + ymin = clgetd ("ymin") + ymax = clgetd ("ymax") + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + } else { + clist = fntopnb (Memc[str], NO) + xmin = INDEFD + xmax = INDEFD + ymin = INDEFD + ymax = INDEFD + nx = clgeti ("nx") + ny = clgeti ("ny") + wcs = clgwrd ("wcs", Memc[str], SZ_FNAME, RG_WCSLIST) + xcolumn = clgeti ("xcolumn") + ycolumn = clgeti ("ycolumn") + call clgstr ("xunits", Memc[str], SZ_FNAME) + xunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (xunits <= 0) + xunits = RG_UNATIVE + call clgstr ("yunits", Memc[str], SZ_FNAME) + yunits = strdic (Memc[str], Memc[str], SZ_FNAME, RG_UNITLIST) + if (yunits <= 0) + yunits = RG_UNATIVE + } + transpose = clgetb ("transpose") + + # Get the output coordinate formatting information. + call clgstr ("xformat", Memc[xformat], SZ_FNAME) + call clgstr ("yformat", Memc[yformat], SZ_FNAME) + call clgstr ("wxformat", Memc[rxformat], SZ_FNAME) + call clgstr ("wyformat", Memc[ryformat], SZ_FNAME) + min_sigdigits = clgeti ("min_sigdigits") + + # Get remaining parameters. + verbose = clgetb ("verbose") + + # Check the formatting of the reference and input logical coordinates. + if (Memc[xformat] == EOS) { + call sprintf (Memc[xformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + if (Memc[yformat] == EOS) { + call sprintf (Memc[yformat], SZ_FNAME, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + + # Check the reference image list length. + if (imtlen (rlist) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen(rlist) > 1 && imtlen(rlist) != imtlen(ilist)) + call error (0, + "The number of reference and input images is not the same.") + + # Check the output coordinate file length. + if (fntlenb(olist) > 1 && fntlenb(olist) != imtlen(ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + + # Check the reference coordinate list length. + if (clist != NULL) { + if (fntlenb (clist) != imtlen (rlist)) + call error (0, + "The number of reference coords files and images are not the same") + } + + # Initialize the reference image and coordinate list pointers. + imr = NULL + cfd = NULL + + # Loop over the input images. + while (imtgetim (ilist, Memc[image], SZ_FNAME) != EOF) { + + # Open the output file. + if (fntgfnb (olist, Memc[str], SZ_FNAME) != EOF) { + ofd = open (Memc[str], NEW_FILE, TEXT_FILE) + if (ofd == STDOUT) + call fseti (ofd, F_FLUSHNL, YES) + else if (fntlenb (olist) != imtlen (ilist)) + call error (0, + "The number of output coords files and input images is not the same.") + } + + # Open the reference image and reference coordinate file and + # compute the logical and world reference coordinates. + if (imtgetim (rlist, Memc[refimage], SZ_FNAME) != EOF) { + + # Open the reference image. + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + imr = immap (Memc[refimage], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "The reference image must be 1D or 2D") + + # Open the reference image wcs. + iferr (mwr = mw_openim (imr)) + mwr = NULL + + # Check that the wcs dimensions are rational. + if (mwr != NULL) { + if (mw_stati(mwr, MW_NPHYSDIM) < IM_NDIM(imr) || + mw_stati (mwr, MW_NDIM) != IM_NDIM(imr)) { + call mw_close (mwr) + mwr = NULL + } + } + + # Get the reference image physical and logical axis maps. + if (mwr != NULL) { + call mw_gaxmap (mwr, Memi[paxno], Memi[rlaxno], + mw_stati(mwr, MW_NPHYSDIM)) + call rg_laxmap (Memi[paxno], mw_stati(mwr, MW_NPHYSDIM), + Memi[rlaxno], mw_stati(mwr, MW_NDIM)) + } else { + Memi[rlaxno] = 1 + Memi[rlaxno+1] = 2 + } + + # Compute the x limits of the logical reference coordinates. + if (IS_INDEFD(xmin)) + x1 = 1.0d0 + else + x1 = max (1.0d0, min (xmin, double(IM_LEN(imr,1)))) + if (IS_INDEFD(xmax)) + x2 = double(IM_LEN(imr,1)) + else + x2 = max (1.0d0, min (xmax, double(IM_LEN(imr,1)))) + + # Compute the y limits of the logical reference coordinates. + if (IM_NDIM(imr) == 1) + y1 = 1.0d0 + else if (IS_INDEFD(ymin)) + y1 = 1.0d0 + else + y1 = max (1.0d0, min (ymin, double(IM_LEN(imr,2)))) + if (IM_NDIM(imr) == 1) + y2 = 1.0d0 + else if (IS_INDEFD(ymax)) + y2 = double(IM_LEN(imr,2)) + else + y2 = max (1.0d0, min (ymax, double(IM_LEN(imr,2)))) + + # Compute the reference logical and world coordinates. + if (clist != NULL) { + + if (cfd != NULL) + call close (cfd) + + if (fntgfnb (clist, Memc[str], SZ_FNAME) != EOF) { + cfd = open (Memc[str], READ_ONLY, TEXT_FILE) + npts = rg_rdxy (cfd, rxw, ryw, wcs, xcolumn, ycolumn, + xunits, yunits) + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "world", + "logical", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxw], Memd[ryw], + Memd[rxl], Memd[ryl], npts, "physical", + "logical", 1, 2) + } + + } else { + + if (IM_NDIM(imr) == 1) + npts = nx + else + npts = nx * ny + call malloc (rxl, npts, TY_DOUBLE) + call malloc (ryl, npts, TY_DOUBLE) + call malloc (rxw, npts, TY_DOUBLE) + call malloc (ryw, npts, TY_DOUBLE) + call malloc (ixl, npts, TY_DOUBLE) + call malloc (iyl, npts, TY_DOUBLE) + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, x1, x2, + y1, y2) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, x1, x2, + y1, y2) + if (wcs == RG_WORLD) + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "world", 1, 2) + else + ctr = rg_xytoxy (mwr, Memd[rxl], Memd[ryl], Memd[rxw], + Memd[ryw], npts, "logical", "physical", 1, 2) + + } + } + + # Open the input image. + im = immap (Memc[image], READ_ONLY, 0) + if (IM_NDIM(im) > 2) + call error (0, "The input image must be 1D or 2D") + if (IM_NDIM(im) != IM_NDIM(imr)) + call error (0, + "The input image must have same dimensionality as reference image") + + # Open the input wcs. + iferr (mw = mw_openim (im)) + mw = NULL + if (mw != NULL) { + if (mw_stati(mw, MW_NPHYSDIM) < IM_NDIM(im) || + mw_stati (mw, MW_NDIM) != IM_NDIM(im)) { + call mw_close (mw) + mw = NULL + } + } + + # Get the input image wcs physical and logical axis maps. + if (mw != NULL) { + call mw_gaxmap (mw, Memi[paxno], Memi[laxno], mw_stati(mw, + MW_NPHYSDIM)) + call rg_laxmap (Memi[paxno], mw_stati(mw, MW_NPHYSDIM), + Memi[laxno], mw_stati(mw, MW_NDIM)) + } else { + Memi[laxno] = 1 + Memi[laxno+1] = 2 + } + + # Write the banner string. + call fprintf (ofd, + "\n# Reference image: %s Input image: %s\n# \tCoords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call fprintf (ofd, "\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call fprintf (ofd, " Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + + # Printe message on the terminal. + if (verbose && ofd != STDOUT) { + call printf ( + "\nReference image: %s Input image: %s\n\tCoords: %s") + call pargstr (Memc[refimage]) + call pargstr (Memc[image]) + if (clist == NULL) { + call pargstr ("grid") + call printf ("\n") + } else { + call fstats (cfd, F_FILENAME, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Wcs: %s\n") + switch (wcs) { + case RG_PHYSICAL: + call pargstr ("physical") + case RG_WORLD: + call pargstr ("world") + default: + call pargstr ("world") + } + } + } + + # Set the reference coordinate formats. + if (Memc[rxformat] == EOS) + call rg_wsetfmt (mwr, mw, wcs, Memi[rlaxno], Memi[laxno], + min_sigdigits, Memc[wxformat], SZ_FNAME) + else + call strcpy (Memc[rxformat], Memc[wxformat], SZ_FNAME) + + if (Memc[ryformat] == EOS) + call rg_wsetfmt (mwr, mw, wcs, Memi[rlaxno+1], Memi[laxno+1], + min_sigdigits, Memc[wyformat], SZ_FNAME) + else + call strcpy (Memc[ryformat], Memc[wyformat], SZ_FNAME) + + # Compute the output coordinates issuing a warning if the + # axes types are not compatable. + if (mwr == NULL) { + call fprintf (ofd, + "# \tWarning: reference image wcs is undefined\n") + if (verbose && ofd != STDOUT) + call printf ( + "\tWarning: reference image wcs is undefined\n") + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + } + ct = NULL + } else if (ctr == NULL) { + call fprintf (ofd, "# \tWarning: Unable to compute reference \ +logical <-> world transform\n") + if (verbose && ofd != STDOUT) { + call printf ("\tWarning: Unable to compute reference \ +logical <-> world transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + if (clist == NULL) { + call amovd (Memd[rxl], Memd[rxw], npts) + call amovd (Memd[ryl], Memd[ryw], npts) + } + ct = NULL + } else if (mw == NULL) { + call fprintf (ofd, + "# \tWarning: input image wcs is undefined\n") + if (verbose && ofd != STDOUT) + call printf ("\tWarning: input image wcs is undefined\n") + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + ct = NULL + } else { + # Check axis status. + if (wcs == RG_PHYSICAL) { + axstat = RG_AXEQUAL + projstat = RG_AXEQUAL + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "physical", "logical", 1, 2) + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image physical -> \ +logical transform\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Unable to compute image physical \ +-> logical transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } + } else { + axstat = rg_axstat (mwr, Memi[rlaxno], Memi[rlaxno+1], + mw, Memi[laxno], Memi[laxno+1], transpose) + projstat = rg_projstat (mwr, Memi[rlaxno], Memi[rlaxno+1], + mw, Memi[laxno], Memi[laxno+1]) + switch (axstat) { + case RG_AXEQUAL, RG_AXNOTEQUAL: + ct = rg_xytoxy (mw, Memd[rxw], Memd[ryw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + case RG_AXSWITCHED: + ct = rg_xytoxy (mw, Memd[ryw], Memd[rxw], Memd[ixl], + Memd[iyl], npts, "world", "logical", 1, 2) + } + if (ct == NULL) { + call fprintf (ofd, + "# \tWarning: Unable to compute image \ + world -> logical transform\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Unable to compute image world -> \ +logical transform\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } else if (axstat == RG_AXNOTEQUAL) { + call fprintf (ofd, + "# \tWarning: Reference and image axtype \ +attributes are different\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Reference and image axtype \ +attributes are different\n") + } + if (IM_NDIM(imr) == 1) + call rg_rxyl (Memd[rxl], Memd[ryl], nx, 1, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, 1.0d0) + else + call rg_rxyl (Memd[rxl], Memd[ryl], nx, ny, 1.0d0, + double(IM_LEN(im,1)), 1.0d0, + double(IM_LEN(im,2))) + call amovd (Memd[rxl], Memd[ixl], npts) + call amovd (Memd[ryl], Memd[iyl], npts) + } else if (projstat == RG_AXNOTEQUAL) { + call fprintf (ofd, + "# \tWarning: Reference and image wtype \ +attributes are different\n") + if (verbose && ofd != STDOUT) { + call printf ( + "\tWarning: Reference and image wtype \ +attributes are different\n") + } + } + } + } + + # Write out the results. + call rg_wcoords (ofd, Memd[rxl], Memd[ryl], Memd[ixl], + Memd[iyl], Memd[rxw], Memd[ryw], npts, Memc[xformat], + Memc[yformat], Memc[wxformat], Memc[wyformat]) + + # Close the input image and its wcs. + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + + # Close the output coordinate file if it is not going to + # be appended to. + if (fntlenb(olist) == imtlen(ilist)) + call close (ofd) + } + + if (imr != NULL) { + call mfree (rxl, TY_DOUBLE) + call mfree (ryl, TY_DOUBLE) + call mfree (rxw, TY_DOUBLE) + call mfree (ryw, TY_DOUBLE) + call mfree (ixl, TY_DOUBLE) + call mfree (iyl, TY_DOUBLE) + if (mwr != NULL) + call mw_close (mwr) + call imunmap (imr) + } + if (cfd != NULL) + call close (cfd) + if (fntlenb(olist) < imtlen(ilist)) + call close (ofd) + if (ilist != NULL) + call imtclose (ilist) + if (rlist != NULL) + call imtclose (rlist) + if (olist != NULL) + call fntclsb (olist) + if (clist != NULL) + call fntclsb (clist) + + call sfree (sp) +end + + +# RG_WSETFMT -- Set the world coordinate format. + +procedure rg_wsetfmt (mwr, mw, wcs, rlaxno, laxno, min_sigdigits, + wformat, maxch) + +pointer mwr #I pointer to the reference image wcs +pointer mw #I pointer to the input image wcs +int wcs #I the input wcs type +int rlaxno #I the reference physical axis number +int laxno #I the input physical axis number +int min_sigdigits #I the minimum number of significant digits +char wformat[ARB] #O the output world coordinate format +int maxch #I the maximum size of the format string + +pointer sp, str +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + if (mwr == NULL || mw == NULL) { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + + } else if (wcs == RG_PHYSICAL) { + call strcpy ("%10.3f", wformat, maxch) + + } else { + iferr { + call mw_gwattrs (mwr, rlaxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mw, laxno, "format", wformat, maxch) + } then { + iferr { + call mw_gwattrs (mwr, rlaxno, "axtype", Memc[str], + SZ_FNAME) + } then { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } else { + if (streq (Memc[str], "ra")) + call strcpy ("%11.1H", wformat, maxch) + else if (streq (Memc[str], "dec")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lon")) + call strcpy ("%11.1h", wformat, maxch) + else if (streq (Memc[str+1], "lat")) + call strcpy ("%11.1h", wformat, maxch) + else { + call sprintf (wformat, maxch, "%%%d.%dg") + call pargi (min_sigdigits + 3) + call pargi (min_sigdigits) + } + } + } + } + } + + call sfree (sp) +end + + +# RG_AXSTAT -- Determine whether or not the two axes are equal. + +int procedure rg_axstat (mw1, ax11, ax12, mw2, ax21, ax22, transpose) + +pointer mw1 #I pointer to the first wcs +int ax11, ax12 #I the logical reference axes +pointer mw2 #I pointer to the second wcs +int ax21, ax22 #I the logical input axes +bool transpose #I transpose the world coordinates + +int stat +pointer sp, xax1, yax1, xax2, yax2 +bool streq() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (xax1, SZ_FNAME, TY_CHAR) + call salloc (yax1, SZ_FNAME, TY_CHAR) + call salloc (xax2, SZ_FNAME, TY_CHAR) + call salloc (yax2, SZ_FNAME, TY_CHAR) + + iferr (call mw_gwattrs (mw1, ax11, "axtype", Memc[xax1], SZ_FNAME)) + Memc[xax1] = EOS + iferr (call mw_gwattrs (mw1, ax12, "axtype", Memc[yax1], SZ_FNAME)) + Memc[yax1] = EOS + iferr (call mw_gwattrs (mw2, ax21, "axtype", Memc[xax2], SZ_FNAME)) + Memc[xax2] = EOS + iferr (call mw_gwattrs (mw2, ax22, "axtype", Memc[yax2], SZ_FNAME)) + Memc[yax2] = EOS + + if (transpose) + stat = RG_AXSWITCHED + else if (streq (Memc[xax1], Memc[xax2]) && streq(Memc[yax1], + Memc[yax2])) + stat = RG_AXEQUAL + else if (streq (Memc[xax1], Memc[yax2]) && streq(Memc[yax1], + Memc[xax2])) + stat = RG_AXSWITCHED + else + stat = RG_AXNOTEQUAL + + call sfree (sp) + + return (stat) +end + + +# RG_PROJSTAT -- Determine whether or not the projections of two axes are equal. + +int procedure rg_projstat (mw1, ax11, ax12, mw2, ax21, ax22) + +pointer mw1 #I pointer to the first wcs +int ax11, ax12 #I the logical reference axes +pointer mw2 #I pointer to the second wcs +int ax21, ax22 #I the logical reference axes + +int stat +pointer sp, xproj1, yproj1, xproj2, yproj2 +bool streq() +errchk mw_gwattrs() + +begin + call smark (sp) + call salloc (xproj1, SZ_FNAME, TY_CHAR) + call salloc (yproj1, SZ_FNAME, TY_CHAR) + call salloc (xproj2, SZ_FNAME, TY_CHAR) + call salloc (yproj2, SZ_FNAME, TY_CHAR) + + iferr (call mw_gwattrs (mw1, ax11, "wtype", Memc[xproj1], SZ_FNAME)) + Memc[xproj1] = EOS + iferr (call mw_gwattrs (mw1, ax12, "wtype", Memc[yproj1], SZ_FNAME)) + Memc[yproj1] = EOS + iferr (call mw_gwattrs (mw2, ax21, "wtype", Memc[xproj2], SZ_FNAME)) + Memc[xproj2] = EOS + iferr (call mw_gwattrs (mw2, ax22, "wtype", Memc[yproj2], SZ_FNAME)) + Memc[yproj2] = EOS + + if (streq (Memc[xproj1], Memc[xproj2]) && streq(Memc[yproj1], + Memc[yproj2])) + stat = RG_AXEQUAL + else if (streq (Memc[xproj1], Memc[yproj2]) && streq(Memc[yproj1], + Memc[xproj2])) + stat = RG_AXSWITCHED + else + stat = RG_AXNOTEQUAL + + call sfree (sp) + + return (stat) +end + + +# RG_WCOORDS -- Write out the reference and input logical coordinates of the +# tie points and the reference world coordinates. + +procedure rg_wcoords (ofd, xref, yref, xin, yin, wxref, wyref, npts, + xformat, yformat, wxformat, wyformat) + +int ofd #I the output file descriptor +double xref[ARB] #I the reference logical x coordinates +double yref[ARB] #I the reference logical y coordinates +double xin[ARB] #I the input logical x coordinates +double yin[ARB] #I the input logical y coordinates +double wxref[ARB] #I the input reference world x coordinates +double wyref[ARB] #I the input reference world y coordinates +int npts #I the number of input points +char xformat[ARB] #I the logical x coordinates format +char yformat[ARB] #I the logical y coordinates format +char wxformat[ARB] #I the world x coordinates format +char wyformat[ARB] #I the world y coordinates format + +int i +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Write the column descriptions. + call fprintf (ofd, + "# \tColumn 1: reference logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 2: reference logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 3: input logical x coordinate\n") + call fprintf (ofd, + "# \tColumn 4: input logical y coordinate\n") + call fprintf (ofd, + "# \tColumn 5: reference world x coordinate\n") + call fprintf (ofd, + "# \tColumn 6: reference world y coordinate\n") + call fprintf (ofd, "\n") + + # Create the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %s %s\n") + call pargstr (xformat) + call pargstr (yformat) + call pargstr (xformat) + call pargstr (yformat) + call pargstr (wxformat) + call pargstr (wyformat) + + do i = 1, npts { + call fprintf (ofd, Memc[fmtstr]) + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xin[i]) + call pargd (yin[i]) + call pargd (wxref[i]) + call pargd (wyref[i]) + } + + call sfree (sp) +end + + +# RG_LAXMAP (paxno, wcsndim, laxno, ndim) + +procedure rg_laxmap (paxno, wcsndim, laxno, ndim) + +int paxno[ARB] #I the physical axis map +int wcsndim #I the number of physical axis dimensions +int laxno[ARB] #O the physical axis map +int ndim #I the number of logical axis dimensions + +int i, j + +begin + if (ndim < wcsndim) { + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + do i = ndim + 1, wcsndim + laxno[i] = 0 + } else { + do i = 1, wcsndim + laxno[i] = i + } +end diff --git a/pkg/images/immatch/src/wcsmatch/wcsxymatch.h b/pkg/images/immatch/src/wcsmatch/wcsxymatch.h new file mode 100644 index 00000000..b92673a6 --- /dev/null +++ b/pkg/images/immatch/src/wcsmatch/wcsxymatch.h @@ -0,0 +1,15 @@ +# Define the permitted input wcs types +define RG_WCSLIST "|physical|world|" + +define RG_PHYSICAL 1 +define RG_WORLD 2 + +# Define the permitted units +define RG_UNITLIST "|hours|native|" +define RG_UHOURS 1 +define RG_UNATIVE 2 + +# Define the relationship between the two axes +define RG_AXEQUAL 1 +define RG_AXSWITCHED 2 +define RG_AXNOTEQUAL 3 diff --git a/pkg/images/immatch/src/xregister/mkpkg b/pkg/images/immatch/src/xregister/mkpkg new file mode 100644 index 00000000..262b721d --- /dev/null +++ b/pkg/images/immatch/src/xregister/mkpkg @@ -0,0 +1,25 @@ +# Make the XREGISTER task + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + rgxbckgrd.x "xregister.h" + rgxcolon.x "xregister.h" + rgxcorr.x "xregister.h" + rgxdbio.x "xregister.h" + rgxfft.x + rgxfit.x "xregister.h" + rgxgpars.x "xregister.h" + rgxicorr.x "xregister.h" + rgximshift.x + rgxplot.x + rgxppars.x "xregister.h" + rgxregions.x "xregister.h" + rgxshow.x "xregister.h" + rgxtools.x "xregister.h" + rgxtransform.x "xregister.h" + t_xregister.x "xregister.h" + ; diff --git a/pkg/images/immatch/src/xregister/oxregister.key b/pkg/images/immatch/src/xregister/oxregister.key new file mode 100644 index 00000000..91064ff8 --- /dev/null +++ b/pkg/images/immatch/src/xregister/oxregister.key @@ -0,0 +1,33 @@ + Xregister Image Overlay Sub-menu + + +? Print help +c Overlay the marked column of the reference image + with the same column of the input image +l Overlay the marked line of the reference image + with the sname line of the input image +x Overlay the marked column of the reference image + with the x and y lagged column of the input image +y Overlay the marked line of the reference image + with the x and y lagged line of the input image +v Overlay the marked column of the reference image + with the x and y shifted column of the input image +h Overlay the marked line of the reference image + with the x and y shifted line of the input image +q Quit + + + Image Overlay Sub-menu Colon Commands + +:c [m] [n] Overlay the middle [mth] column of the reference image + with the mth [nth] column of the input image +:l [m] [n] Overlay the middle [mth] line of the reference image + with the mth [nth] line of the input image +:x [m] Overlay the middle [mth] column of the reference image + with the x and y lagged column of the input image +:y [m] Overlay the middle [mth] line of the reference image + with the x and y lagged line of the input image +:v [m] Overlay the middle [mth] column of the reference image + with the x and y shifted column of the input image +:h [m] Overlay the middle [mth] line of the reference image + with the x and y shifted line of the input image diff --git a/pkg/images/immatch/src/xregister/rgxbckgrd.x b/pkg/images/immatch/src/xregister/rgxbckgrd.x new file mode 100644 index 00000000..c9747ee6 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxbckgrd.x @@ -0,0 +1,63 @@ +include +include "xregister.h" + +# RG_XSCALE -- Compute the background offset and x and y slope. + +procedure rg_xscale (xc, data, npts, nx, ny, offset, coeff) + +pointer xc #I pointer to the cross-correlation function +real data[ARB] #I the input data +int npts #I the number of points +int nx, ny #I the dimensions of the original subraster +real offset #I the input offset +real coeff[ARB] #O the output coefficients + +int wborder +pointer gs +real loreject, hireject, zero +int rg_xstati(), rg_znsum(), rg_znmedian(), rg_slope() +real rg_xstatr() + +begin + loreject = rg_xstatr (xc, LOREJECT) + hireject = rg_xstatr (xc, HIREJECT) + wborder = rg_xstati (xc, BORDER) + + switch (rg_xstati (xc, BACKGRD)) { + case XC_BNONE: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_MEAN: + if (rg_znsum (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_MEDIAN: + if (rg_znmedian (data, npts, zero, loreject, hireject) <= 0) + zero = 0.0 + coeff[1] = zero + coeff[2] = 0.0 + coeff[3] = 0.0 + case XC_SLOPE: + call gsinit (gs, GS_POLYNOMIAL, 2, 2, GS_XNONE, 1.0, real (nx), 1.0, + real (ny)) + if (rg_slope (gs, data, npts, nx, ny, wborder, wborder, loreject, + hireject) == ERR) { + coeff[1] = 0.0 + coeff[2] = 0.0 + coeff[3] = 0.0 + } else { + call gssave (gs, coeff) + coeff[1] = coeff[GS_SAVECOEFF+1] + coeff[2] = coeff[GS_SAVECOEFF+2] + coeff[3] = coeff[GS_SAVECOEFF+3] + } + call gsfree (gs) + default: + coeff[1] = offset + coeff[2] = 0.0 + coeff[3] = 0.0 + } +end diff --git a/pkg/images/immatch/src/xregister/rgxcolon.x b/pkg/images/immatch/src/xregister/rgxcolon.x new file mode 100644 index 00000000..cb007473 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxcolon.x @@ -0,0 +1,508 @@ +include +include +include +include "xregister.h" + +# RG_XCOLON-- Procedure to process colon commands for setting the cross- +# correlation parameters. + +procedure rg_xcolon (gd, xc, imr, im1, im2, db, dformat, tfd, reglist, cmdstr, + newdata, newcross, newcenter) + +pointer gd #I pointer to the graphics stream +pointer xc #I pointer to cross-correlation structure +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the shifts database file +int dformat #I is the shifts file in database format +int tfd #I/O the transformations file descriptor +pointer reglist #I/O pointer to the regions list +char cmdstr[ARB] #I input command string +int newdata #I/O new input data +int newcross #I/O new cross-correlation function flag +int newcenter #I/O new cross-correlation peak flag + +bool streq() +int ncmd, creg, nreg, ival, stat +pointer sp, cmd, str +real rval +int strdic(), open(), nscan(), rg_xstati(), fntopnb() +int rg_xregions(), rg_xmkregions(), strlen() +pointer immap(), dtmap(), rg_xstatp() +real rg_xstatr() +errchk immap(), dtmap(), open(), fntopnb() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + # Process the command. + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XCMDS) + switch (ncmd) { + case XCMD_REFIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + } else { + if (imr != NULL) { + call imunmap (imr) + imr = NULL + } + iferr { + imr = immap (Memc[cmd], READ_ONLY, 0) + } then { + call erract (EA_WARN) + imr = immap (Memc[str], READ_ONLY, 0) + } else if (IM_NDIM(imr) > 2 || IM_NDIM(imr) != IM_NDIM(im1)) { + call printf ( + "Image has the wrong number of dimensions\n") + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + } else { + call rg_xsets (xc, REFIMAGE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + } + + case XCMD_IMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + } else { + if (im1 != NULL) { + call imunmap (im1) + im1 = NULL + } + iferr { + im1 = immap (Memc[cmd], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } then { + call erract (EA_WARN) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else if (IM_NDIM(im1) > 2 || IM_NDIM(im1) != IM_NDIM(imr)) { + call printf ( + "Image has the wrong number of dimensions\n") + call imunmap (im1) + im1 = immap (Memc[str], READ_ONLY, 0) + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + } else { + call rg_xsets (xc, IMAGE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + } + + case XCMD_OUTIMAGE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, OUTIMAGE, Memc[str], SZ_FNAME) + if (im2 == NULL || Memc[cmd] == EOS || streq (Memc[cmd], + Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + if (im2 != NULL) { + call imunmap (im2) + im2 = NULL + } + iferr { + im2 = immap (Memc[cmd], NEW_COPY, im1) + } then { + call erract (EA_WARN) + im2 = immap (Memc[str], NEW_COPY, im1) + } else { + call rg_xsets (xc, OUTIMAGE, Memc[cmd]) + } + } + + case XCMD_DATABASE: + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, DATABASE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + } else { + if (db != NULL) { + if (dformat == YES) + call dtunmap (db) + else + call close (db) + db = NULL + } + iferr { + if (dformat == YES) + db = dtmap (Memc[cmd], APPEND) + else + db = open (Memc[cmd], NEW_FILE, TEXT_FILE) + } then { + call erract (EA_WARN) + if (dformat == YES) + db = dtmap (Memc[str], APPEND) + else + db = open (Memc[str], APPEND, TEXT_FILE) + } else { + call rg_xsets (xc, DATABASE, Memc[cmd]) + } + } + + CASE XCMD_RECORD: + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + } else + call rg_xsets (xc, RECORD, Memc[cmd]) + + case XCMD_CREGION: + + call gargi (nreg) + creg = rg_xstati (xc, CREGION) + + if (nscan() == 1 || (nreg == creg)) { + call printf ("%s: %d/%d") + call pargstr (KY_CREGION) + call pargi (creg) + call pargi (rg_xstati (xc, NREGIONS)) + call printf (" [%d:%d,%d:%d]\n") + call pargi (Memi[rg_xstatp (xc,RC1)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RC2)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RL1)+creg-1]) + call pargi (Memi[rg_xstatp (xc,RL2)+creg-1]) + + } else { + if (nreg < 1 || nreg > rg_xstati (xc,NREGIONS)) { + call printf ("Region %d is out of range\n") + call pargi (nreg) + } else { + call printf ( + "Setting current region to %d: [%d:%d,%d:%d]\n") + call pargi (nreg) + call pargi (Memi[rg_xstatp (xc,RC1)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RC2)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RL1)+nreg-1]) + call pargi (Memi[rg_xstatp (xc,RL2)+nreg-1]) + call rg_xseti (xc, CREGION, nreg) + newdata = YES; newcross = YES; newcenter = YES + } + + } + + case XCMD_REGIONS: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REGIONS, Memc[str], SZ_FNAME) + if (nscan() == 1 || streq (Memc[cmd], Memc[str]) || Memc[cmd] == + EOS) { + call printf ("%s [string/file]: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + iferr (reglist = fntopnb (Memc[cmd], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) { + call rg_xseti (xc, CREGION, 1) + call rg_xsets (xc, REGIONS, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } else { + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) + ; + call rg_xsets (xc, REGIONS, Memc[str]) + call rg_xseti (xc, CREGION, 1) + } + } + + case XCMD_REFFILE: + + call gargwrd (Memc[cmd], SZ_LINE) + call rg_xstats (xc, REFFILE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_REFFILE) + call pargstr (Memc[str]) + } else { + if (tfd != NULL) { + call close (tfd) + tfd = NULL + } + iferr { + tfd = open (Memc[cmd], READ_ONLY, TEXT_FILE) + } then { + tfd = NULL + call erract (EA_WARN) + call rg_xsets (xc, REFFILE, "") + call printf ("Coords file is undefined.\n") + } else + call rg_xsets (xc, REFFILE, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_XLAG: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XLAG) + call pargi (rg_xstati (xc, XLAG)) + } else { + call rg_xseti (xc, XLAG, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_YLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_YLAG) + call pargi (rg_xstati (xc, YLAG)) + } else { + call rg_xseti (xc, YLAG, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_DXLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DXLAG) + call pargi (rg_xstati (xc, DXLAG)) + } else { + call rg_xseti (xc, DXLAG, ival) + } + + case XCMD_DYLAG: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_DYLAG) + call pargi (rg_xstati (xc, DYLAG)) + } else { + call rg_xseti (xc, DYLAG, ival) + } + + case XCMD_BACKGROUND: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] != EOS) + call strcat (" ", Memc[cmd], SZ_LINE) + call gargwrd (Memc[cmd+strlen(Memc[cmd])], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, BSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_BACKGROUND) + call pargstr (Memc[str]) + } else { + call rg_xsets (xc, BSTRING, Memc[cmd]) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_BORDER: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_BORDER) + call pargi (rg_xstati (xc, BORDER)) + } else { + call rg_xseti (xc, BORDER, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_LOREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_xstatr (xc, LOREJECT)) + } else { + call rg_xsetr (xc, LOREJECT, rval) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_HIREJECT: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_HIREJECT) + call pargr (rg_xstatr (xc, HIREJECT)) + } else { + call rg_xsetr (xc, HIREJECT, rval) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_APODIZE: + call gargr (rval) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_xstatr (xc, APODIZE)) + } else { + call rg_xsetr (xc, APODIZE, max (0.0, min (rval, 0.50))) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_CORRELATION: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, CSTRING, Memc[str], SZ_FNAME) + call printf ("%s = %s\n") + call pargstr (KY_CORRELATION) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XC_CTYPES) + if (stat > 0) { + call rg_xseti (xc, CFUNC, stat) + call rg_xsets (xc, CSTRING, Memc[cmd]) + newcross = YES; newcenter = YES + } + } + + case XCMD_XWINDOW: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XWINDOW) + call pargi (rg_xstati (xc, XWINDOW)) + } else { + call rg_xseti (xc, XWINDOW, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_YWINDOW: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_YWINDOW) + call pargi (rg_xstati (xc, YWINDOW)) + } else { + call rg_xseti (xc, YWINDOW, ival) + newdata = YES; newcross = YES; newcenter = YES + } + + case XCMD_PEAKCENTER: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call rg_xstats (xc, PSTRING, Memc[str], SZ_FNAME) + call printf ("%s: %s\n") + call pargstr (KY_PEAKCENTER) + call pargstr (Memc[str]) + } else { + stat = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XC_PTYPES) + if (stat > 0) { + call rg_xseti (xc, PFUNC, stat) + call rg_xsets (xc, PSTRING, Memc[cmd]) + newcenter = YES + } + } + + case XCMD_XCBOX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %d\n") + call pargstr (KY_XCBOX) + call pargi (rg_xstati (xc, XCBOX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_xseti (xc, XCBOX, ival) + newcenter = YES + } + + case XCMD_YCBOX: + call gargi (ival) + if (nscan() == 1) { + call printf ("%s = %g\n") + call pargstr (KY_YCBOX) + call pargi (rg_xstati (xc, YCBOX)) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + call rg_xseti (xc, YCBOX, ival) + newcenter = YES + } + + case XCMD_SHOW: + call gdeactivate (gd, 0) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, XSHOW) + switch (ncmd) { + case XSHOW_DATA: + call rg_xnshow (xc) + case XSHOW_BACKGROUND: + call rg_xbshow (xc) + case XSHOW_CORRELATION: + call rg_xxshow (xc) + case XSHOW_PEAKCENTER: + call rg_xpshow (xc) + default: + call rg_xshow (xc) + } + call greactivate (gd, 0) + + case XCMD_MARK: + call gdeactivate (gd, 0) + if (reglist != NULL) { + call fntclsb (reglist) + reglist = NULL + } + if (rg_xmkregions (imr, xc, 1, MAX_NREGIONS, Memc[str], + SZ_LINE) <= 0) { + call rg_xstats (xc, REGIONS, Memc[str], SZ_LINE) + iferr (reglist = fntopnb (Memc[str], NO)) + reglist = NULL + if (rg_xregions (reglist, imr, xc, 1) > 0) + ; + call rg_xsets (xc, REGIONS, Memc[str]) + call rg_xseti (xc, CREGION, 1) + } else { + call rg_xseti (xc, CREGION, 1) + call rg_xsets (xc, REGIONS, Memc[str]) + newdata = YES; newcross = YES; newcenter = YES + } + call greactivate (gd, 0) + default: + call printf ("Unknown or ambiguous colon command\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxcorr.x b/pkg/images/immatch/src/xregister/rgxcorr.x new file mode 100644 index 00000000..a708bf7a --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxcorr.x @@ -0,0 +1,1034 @@ +include +include +include +include "xregister.h" + +# RG_XCORR -- Compute the shift shift for an image relative to a reference +# image using cross-correlation techniques. + +int procedure rg_xcorr (imr, im1, db, dformat, xc) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer db #I pointer to the shifts database +int dformat #I write shifts file in database format ? +pointer xc #I pointer to the cross-correlation structure + +pointer sp, image, imname +real xshift, yshift +bool streq() +int rg_xstati(), fscan(), nscan() +errchk rg_cross(), rg_xfile() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call rg_xstats (xc, IMAGE, Memc[image], SZ_FNAME) + + # Initialize. + xshift = 0.0 + yshift = 0.0 + + # Compute the average shift for the image. + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE, XC_FOURIER: + + # Write out the parameters. + if (dformat == YES) + call rg_xdbparams (db, xc) + + # Compute the cross-correlation function. + call rg_cross (imr, im1, xc, NULL, xshift, yshift) + call rg_xsetr (xc, TXSHIFT, xshift) + call rg_xsetr (xc, TYSHIFT, yshift) + + # Write out the results for the individual regions. + if (dformat == YES) + call rg_xwreg (db, xc) + + # Write out the total shifts. + if (dformat == YES) + call rg_xdbshift (db, xc) + else { + call fprintf (db, "%s %g %g\n") + call pargstr (Memc[image]) + call pargr (xshift) + call pargr (yshift) + } + + # Set the x and y lags for the next picture. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_xseti (xc, XLAG, 0) + call rg_xseti (xc, YLAG, 0) + } else if (IS_INDEFI (rg_xstati (xc, DXLAG)) || + IS_INDEFI (rg_xstati (xc, DYLAG))) { + call rg_xseti (xc, XLAG, nint (-xshift)) + call rg_xseti (xc, YLAG, nint (-yshift)) + } else { + call rg_xseti (xc, XLAG, rg_xstati (xc, XLAG) + rg_xstati (xc, + DXLAG)) + call rg_xseti (xc, YLAG, rg_xstati (xc, YLAG) + rg_xstati (xc, + DYLAG)) + } + + case XC_FILE: + if (dformat == YES) + call rg_xfile (db, xc, xshift, yshift) + else { + if (fscan (db) != EOF) { + call gargwrd (Memc[imname], SZ_FNAME) + call gargr (xshift) + call gargr (yshift) + if (! streq (Memc[imname], Memc[image]) || nscan() != 3) { + xshift = 0.0 + yshift = 0.0 + } + } else { + xshift = 0.0 + yshift = 0.0 + } + } + call rg_xsetr (xc, TXSHIFT, xshift) + call rg_xsetr (xc, TYSHIFT, yshift) + + default: + call error (0, "The correlation function is undefined.") + } + + call sfree (sp) + + return (NO) +end + + +# RG_CROSS -- Compute the cross-correlation function for all the regions +# using discrete, fourier, or difference techniques and compute the position +# of its peak using one of several centering algorithms. + +procedure rg_cross (imr, im1, xc, gd, xavshift, yavshift) + +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +pointer xc #I pointer to the cross correlation structure +pointer gd #I pointer to graphics stream +real xavshift #O x coord shift +real yavshift #O y coord shift + +int i, nregions, ngood +pointer pxshift, pyshift +real xshift, yshift +int rg_xstati(), rg_xcget(), rg_xfget() +pointer rg_xstatp() + +begin + # Get the pointers. + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + # Loop over the regions. + xavshift = 0.0 + yavshift = 0.0 + ngood = 0 + do i = 1, nregions { + + # Compute the cross_correlation function. + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE: + if (rg_xcget (xc, imr, im1, i) == ERR) { + Memr[pxshift+i-1] = INDEFR + Memr[pyshift+i-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + next + } + case XC_FOURIER: + if (rg_xfget (xc, imr, im1, i) == ERR) { + Memr[pxshift+i-1] = INDEFR + Memr[pyshift+i-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + next + } + default: + call error (0, "The correlation function is undefined") + } + + # Find the peak of the cross-correlation function. + call rg_fit (xc, i, gd, xshift, yshift) + + # Accumulate the shifts. + xavshift = xavshift + xshift + yavshift = yavshift + yshift + ngood = ngood + 1 + } + + # Compute the average shift. + if (ngood > 0) { + xavshift = xavshift / ngood + yavshift = yavshift / ngood + } +end + + +# RG_XFILE -- Read the average x and y shifts from the shifts database. + +procedure rg_xfile (db, xc, xshift, yshift) + +pointer db #I pointer to the database +pointer xc #I pointer to the cross correlation structure +real xshift #O shift in x +real yshift #O shift in y + +int rec +pointer sp, str +int dtlocate() +real dtgetr() +errchk dtlocate(), dtgetr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call rg_xstats (xc, RECORD, Memc[str], SZ_LINE) + iferr { + rec = dtlocate (db, Memc[str]) + xshift = dtgetr (db, rec, "xshift") + yshift = dtgetr (db, rec, "yshift") + } then { + xshift = 0.0 + yshift = 0.0 + } + + call sfree (sp) +end + + +# RG_ICROSS -- Compute the cross-correlation function for a given region. + +int procedure rg_icross (xc, imr, im1, nreg) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +int nreg #I the index of the current region + +int stat +pointer pxshift, pyshift +int rg_xstati(), rg_xcget(), rg_xfget() +pointer rg_xstatp() + +begin + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + + switch (rg_xstati (xc, CFUNC)) { + case XC_DISCRETE, XC_DIFFERENCE: + stat = rg_xcget (xc, imr, im1, nreg) + if (stat == ERR) { + Memr[pxshift+nreg-1] = INDEFR + Memr[pyshift+nreg-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + } + case XC_FOURIER: + stat = rg_xfget (xc, imr, im1, nreg) + if (stat == ERR) { + Memr[pxshift+nreg-1] = INDEFR + Memr[pyshift+nreg-1] = INDEFR + if (rg_xstatp (xc, XCOR) != NULL) + call mfree (rg_xstatp (xc, XCOR), TY_REAL) + call rg_xsetp (xc, XCOR, NULL) + } + case XC_FILE: + stat = OK + } + + return (stat) +end + + +# RG_XCGET -- Compute the convolution using the discrete or difference +# correlation functions. + +int procedure rg_xcget (xc, imr, im1, i) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to input image image +int i #I index of region + +int stat, xwindow, ywindow, nrimcols, nrimlines, nimcols, nimlines +int nrcols, nrlines, ncols, nlines +int xlag, ylag, nborder, rc1, rc2, rl1, rl2, c1, c2, l1, l2 +pointer sp, str, coeff, rbuf, ibuf, xcor +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope, border +real rxlag, rylag +int rg_xstati(), rg_border() +pointer rg_xstatp(), rg_ximget() +real rg_xstatr() + +define nextregion_ 10 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF + 6, 9), TY_REAL) + rbuf = NULL + ibuf = NULL + + # Check for regions. + if (i > rg_xstati (xc, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Get the image sizes. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the reference region pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + przero = rg_xstatp (xc, RZERO) + prxslope = rg_xstatp (xc, RXSLOPE) + pryslope = rg_xstatp (xc, RYSLOPE) + + # Compute the reference region limits. + rc1 = max (1, min (int (nrimcols), Memi[prc1+i-1])) + rc2 = min (int (nrimcols), max (1, Memi[prc2+i-1])) + rl1 = max (1, min (int (nrimlines), Memi[prl1+i-1])) + rl2 = min (int (nrimlines), max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Move to the next reference region if current region is off the image. + if (rc1 > nrimcols || rc2 < 1 || rl1 > nrimlines || rl2 < 1) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Check the window sizes. + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Move to next ref regions if current region is too small. + if (nrcols < xwindow || (IM_NDIM(imr) == 2 && nrlines < ywindow)) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Apply the transformation if defined or lag to the ref regions. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, (rc1 + rc2) / 2.0, (rl1 + rl2) / 2.0, + rxlag, rylag) + xlag = rxlag - (rc1 + rc2) / 2.0 + if (ywindow == 1) + ylag = 0 + else + ylag = rylag - (rl1 + rl2) / 2.0 + } else { + xlag = rg_xstati (xc, XLAG) + if (ywindow == 1) + ylag = 0 + else + ylag = rg_xstati (xc, YLAG) + } + + # Get the input image limits. + c1 = rc1 + xlag - xwindow / 2 + c2 = rc2 + xlag + xwindow / 2 + l1 = rl1 + ylag - ywindow / 2 + l2 = rl2 + ylag + ywindow / 2 + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Move to the next ref region if input region is off image. + if (c1 > nimcols || c2 < 1 || l1 > nimlines || l2 < 1) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Move to the next ref region if input region is less than 3 by 3. + if ((ncols < xwindow) || (IM_NDIM(im1) == 2 && nlines < ywindow)) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Get the input reference and input image data. + rbuf = rg_ximget (imr, rc1, rc2, rl1, rl2) + if (rbuf == NULL) { + stat = ERR + goto nextregion_ + } + ibuf = rg_ximget (im1, c1, c2, l1, l2) + if (ibuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Do the background subtraction. + + # Compute the zero point, x slope and y slope of ref image. + if (IS_INDEFR(Memr[przero+i-1]) || IS_INDEFR(Memr[prxslope+i- 1]) || + IS_INDEFR(Memr[pryslope+i-1])) { + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[rbuf], nrcols * nrlines, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, + max (0, nrcols - 2 * rg_xstati (xc, BORDER)), + max (0, nrlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + } + + call rg_subtract (Memr[rbuf], nrcols, nrlines, Memr[przero+i-1], + Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Compute the zero point, and the x and y slopes of input image. + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[ibuf], ncols * nlines, ncols, + nlines, rg_xstatr (xc, BVALUE), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[ibuf], ncols, nlines, + max (0, ncols - 2 * rg_xstati (xc, BORDER)), + max (0, nlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, ncols, nlines, + rg_xstatr (xc, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Subtract the baseline. + call rg_subtract (Memr[ibuf], ncols, nlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) { + call rg_apodize (Memr[rbuf], nrcols, nrlines, rg_xstatr (xc, + APODIZE), YES) + call rg_apodize (Memr[ibuf], ncols, nlines, rg_xstatr (xc, + APODIZE), YES) + } + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[rbuf], nrcols, nrlines, 1.0) + call rg_xlaplace (Memr[ibuf], ncols, nlines, 1.0) + default: + ; + } + + # Allocate space for the cross-correlation function. + if (rg_xstatp (xc, XCOR) == NULL) { + call malloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } else { + xcor = rg_xstatp (xc, XCOR) + call realloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } + + # Clear the correlation function. + call aclrr (Memr[xcor], xwindow * ywindow) + + # Compute the cross-correlation function. + if (rg_xstati (xc, CFUNC) == XC_DISCRETE) { + call rg_xconv (Memr[rbuf], nrcols, nrlines, Memr[ibuf], ncols, + nlines, Memr[xcor], xwindow, ywindow) + } else { + call rg_xdiff (Memr[rbuf], nrcols, nrlines, Memr[ibuf], ncols, + nlines, Memr[xcor], xwindow, ywindow) + } + + stat = OK + +nextregion_ + + # Free memory. + call sfree (sp) + if (rbuf != NULL) + call mfree (rbuf, TY_REAL) + if (ibuf != NULL) + call mfree (ibuf, TY_REAL) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_XFGET -- Compute the cross-correlation function using Fourier techniques. + +int procedure rg_xfget (xc, imr, im1, i) + +pointer xc #I pointer to the cross-correlation structure +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image +int i #I index of the current region + +int rc1, rc2, rl1, rl2, nrcols, nrlines, c1, c2, l1, l2, ncols, nlines +int nrimcols, nrimlines, nimcols, nimlines +int xwindow, ywindow, xlag, nxfft, nyfft, ylag, stat, nborder +pointer sp, str, coeff, xcor, rbuf, ibuf, fft, border +pointer prc1, prc2, prl1, prl2, przero, prxslope, pryslope +real rxlag, rylag +int rg_xstati(), rg_border(), rg_szfft() +pointer rg_xstatp(), rg_ximget() +real rg_xstatr() + +define nextregion_ 11 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (coeff, max (GS_SAVECOEFF+6, 9), TY_REAL) + + # Check for number of regions. + if (i > rg_xstati (xc, NREGIONS)) { + stat = ERR + goto nextregion_ + } + + # Allocate space for the cross-correlation function. + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + + # Get the regions pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + przero = rg_xstatp (xc, RZERO) + prxslope = rg_xstatp (xc, RXSLOPE) + pryslope = rg_xstatp (xc, RYSLOPE) + + # Get the reference subraster region. + rc1 = max (1, min (int (nrimcols), Memi[prc1+i-1])) + rc2 = min (int (nrimcols), max (1, Memi[prc2+i-1])) + rl1 = max (1, min (int (nrimlines), Memi[prl1+i-1])) + rl2 = min (int (nrimlines), max (1, Memi[prl2+i-1])) + nrcols = rc2 - rc1 + 1 + nrlines = rl2 - rl1 + 1 + + # Go to next region if the reference region is off the image. + if (rc1 > nrimcols || rc2 < 1 || rl1 > nrimlines || rl2 < 1) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Check the window sizes. + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Go to the next region if the reference region has too few points. + if ((nrcols < xwindow) || (IM_NDIM(im1) == 2 && nrlines < ywindow)) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Reference section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + stat = ERR + goto nextregion_ + } + + # Apply the transformation if defined or the lag. + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, (rc1 + rc2) / 2.0, (rl1 + rl2) / 2.0, + rxlag, rylag) + xlag = rxlag - (rc1 + rc2) / 2.0 + if (ywindow == 1) + ylag = 0 + else + ylag = rylag - (rl1 + rl2) / 2.0 + } else { + xlag = rg_xstati (xc, XLAG) + if (ywindow == 1) + ylag = 0 + else + ylag = rg_xstati (xc, YLAG) + } + + # Get the input image subraster regions. + c1 = rc1 + xlag + c2 = rc2 + xlag + l1 = rl1 + ylag + l2 = rl2 + ylag + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + + # Go to next region if region is off the image. + if (c1 > nimcols || c2 < 1 || l1 > nimlines || l2 < 1) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] is off image.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Go to next region if region has too few points. + if ((ncols < xwindow) || (IM_NDIM(im1) == 2 && nlines < ywindow)) { + call rg_xstats (xc, IMAGE, Memc[str], SZ_LINE) + call eprintf ( + "Image section: %s[%d:%d,%d:%d] has too few points.\n") + call pargstr (Memc[str]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + stat = ERR + goto nextregion_ + } + + # Figure out how big the Fourier transform has to be, given + # the size of the reference subraster, the window size and + # the fact that the FFT must be a power of 2. + + nxfft = rg_szfft (nrcols, xwindow) + if (ywindow == 1) + nyfft = 1 + else + nyfft = rg_szfft (nrlines, ywindow) + call calloc (fft, 2 * nxfft * nyfft, TY_REAL) + + # Get the input reference and input image data. + rbuf = NULL + rbuf = rg_ximget (imr, rc1, rc2, rl1, rl2) + if (rbuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Do the background subtraction. + + # Compute the zero point, x slope and y slope of ref image. + if (IS_INDEFR(Memr[przero+i-1]) || IS_INDEFR(Memr[prxslope+i- 1]) || + IS_INDEFR(Memr[pryslope+i-1])) { + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[rbuf], nrcols * nrlines, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[rbuf], nrcols, nrlines, + max (0, nrcols - 2 * rg_xstati (xc, BORDER)), + max (0, nrlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, nrcols, + nrlines, rg_xstatr (xc, BVALUER), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Save the coefficients. + Memr[przero+i-1] = Memr[coeff] + Memr[prxslope+i-1] = Memr[coeff+1] + Memr[pryslope+i-1] = Memr[coeff+2] + } + + call rg_subtract (Memr[rbuf], nrcols, nrlines, Memr[przero+i-1], + Memr[prxslope+i-1], Memr[pryslope+i-1]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) + call rg_apodize (Memr[rbuf], nrcols, nrlines, rg_xstatr (xc, + APODIZE), YES) + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[rbuf], nrcols, nrlines, 1.0) + default: + ; + } + + # Load the reference data into the FFT. + call rg_rload (Memr[rbuf], nrcols, nrlines, Memr[fft], nxfft, nyfft) + call mfree (rbuf, TY_REAL) + + ibuf = NULL + ibuf = rg_ximget (im1, c1, c2, l1, l2) + if (ibuf == NULL) { + stat = ERR + goto nextregion_ + } + + # Compute the zero point, and the x and y slopes of input image. + if (IS_INDEFI(rg_xstati (xc, BORDER))) { + call rg_xscale (xc, Memr[ibuf], ncols * nlines, ncols, + nlines, rg_xstatr (xc, BVALUE), Memr[coeff]) + } else { + border = NULL + nborder = rg_border (Memr[ibuf], ncols, nlines, + max (0, ncols - 2 * rg_xstati (xc, BORDER)), + max (0, nlines - 2 * rg_xstati (xc, BORDER)), + border) + call rg_xscale (xc, Memr[border], nborder, ncols, nlines, + rg_xstatr (xc, BVALUE), Memr[coeff]) + if (border != NULL) + call mfree (border, TY_REAL) + } + + # Subtract the baseline. + call rg_subtract (Memr[ibuf], ncols, nlines, Memr[coeff], + Memr[coeff+1], Memr[coeff+2]) + + # Apodize the data. + if (rg_xstatr (xc, APODIZE) > 0.0) + call rg_apodize (Memr[ibuf], ncols, nlines, rg_xstatr (xc, + APODIZE), YES) + + # Spatially filter the data with a Laplacian. + switch (rg_xstati (xc, FILTER)) { + case XC_LAPLACE: + call rg_xlaplace (Memr[ibuf], ncols, nlines, 1.0) + default: + ; + } + + # Load the image data into the FFT. + call rg_iload (Memr[ibuf], ncols, nlines, Memr[fft], nxfft, nyfft) + call mfree (ibuf, TY_REAL) + + # Normalize the data. + call rg_fnorm (Memr[fft], nrcols, nrlines, nxfft, nyfft) + + # Compute the cross-correlation function. + call rg_fftcor (Memr[fft], nxfft, nyfft) + + # Allocate space for the correlation function. + if (rg_xstatp (xc, XCOR) == NULL) { + call malloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } else { + xcor = rg_xstatp (xc, XCOR) + call realloc (xcor, xwindow * ywindow, TY_REAL) + call rg_xsetp (xc, XCOR, xcor) + } + + # Move the valid lags into the crosscorrelation array + call rg_movexr (Memr[fft], nxfft, nyfft, Memr[xcor], xwindow, ywindow) + + # Free space. + call mfree (fft, TY_REAL) + + stat = OK + +nextregion_ + + call sfree (sp) + if (stat == ERR) + return (ERR) + else + return (OK) +end + + +# RG_XIMGET -- Fill a buffer from a specified region of the image. + +pointer procedure rg_ximget (im, c1, c2, l1, l2) + +pointer im #I pointer to the iraf image +int c1, c2 #I column limits in the input image +int l1, l2 #I line limits in the input image + +int i, ncols, nlines, npts +pointer ptr, index, buf +pointer imgs1r(), imgs2r() + +begin + ncols = c2 - c1 + 1 + nlines = l2 - l1 + 1 + npts = ncols * nlines + call malloc (ptr, npts, TY_REAL) + + index = ptr + do i = l1, l2 { + if (IM_NDIM(im) == 1) + buf = imgs1r (im, c1, c2) + else + buf = imgs2r (im, c1, c2, i, i) + call amovr (Memr[buf], Memr[index], ncols) + index = index + ncols + } + + return (ptr) +end + + +# RG_XLAPLACE -- Compute the Laplacian of an image subraster in place. + +procedure rg_xlaplace (data, nx, ny, rho) + +real data[nx,ARB] #I the input array +int nx, ny #I the size of the input/output data array +real rho #I the pixel to pixel correlation factor + +int i, inline, outline, nxk, nyk, nxc +pointer sp, lineptrs, ptr +real rhosq, kernel[3,3] +data nxk /3/, nyk /3/ + +begin + # Define the kernel. + rhosq = rho * rho + kernel[1,1] = rhosq + kernel[2,1] = -rho * (1.0 + rhosq) + kernel[3,1] = rhosq + kernel[1,2] = -rho * (1.0 + rhosq) + kernel[2,2] = (1.0 + rhosq) * (1 + rhosq) + kernel[3,2] = -rho * (1.0 + rhosq) + kernel[1,3] = rhosq + kernel[2,3] = -rho * (1.0 + rhosq) + kernel[3,3] = rhosq + + # Set up an array of line pointers. + call smark (sp) + call salloc (lineptrs, nyk, TY_POINTER) + + # Allocate working space. + nxc = nx + 2 * (nxk / 2) + do i = 1, nyk + call salloc (Memi[lineptrs+i-1], nxc, TY_REAL) + + inline = 1 - nyk / 2 + do i = 1, nyk - 1 { + if (inline < 1) { + call amovr (data[1,1], Memr[Memi[lineptrs+i]+nxk/2], nx) + Memr[Memi[lineptrs+i]] = data[1,1] + Memr[Memi[lineptrs+i]+nxc-1] = data[nx,1] + } else { + call amovr (data[1,i-1], Memr[Memi[lineptrs+i]+nxk/2], nx) + Memr[Memi[lineptrs+i]] = data[1,i-1] + Memr[Memi[lineptrs+i]+nxc-1] = data[nx,i-1] + } + inline = inline + 1 + } + + # Generate the output image line by line + do outline = 1, ny { + + # Scroll the input buffers + ptr = Memi[lineptrs] + do i = 1, nyk - 1 + Memi[lineptrs+i-1] = Memi[lineptrs+i] + Memi[lineptrs+nyk-1] = ptr + + # Read in new image line + if (inline > ny) { + call amovr (data[1,ny], Memr[Memi[lineptrs+nyk-1]+nxk/2], + nx) + Memr[Memi[lineptrs+nyk-1]] = data[1,ny] + Memr[Memi[lineptrs+nyk-1]+nxc-1] = data[nx,ny] + } else { + call amovr (data[1,inline], Memr[Memi[lineptrs+nyk-1]+nxk/2], + nx) + Memr[Memi[lineptrs+nyk-1]] = data[1,inline] + Memr[Memi[lineptrs+nyk-1]+nxc-1] = data[nx,inline] + } + + # Generate output image line + call aclrr (data[1,outline], nx) + do i = 1, nyk + call acnvr (Memr[Memi[lineptrs+i-1]], data[1,outline], nx, + kernel[1,i], nxk) + + inline = inline + 1 + } + + # Free the image buffer pointers + call sfree (sp) +end + + +# RG_XCONV -- Compute the cross-correlation function directly in the spatial +# domain. + +procedure rg_xconv (ref, nrcols, nrlines, image, ncols, nlines, xcor, xwindow, + ywindow) + +real ref[nrcols,nrlines] #I the input reference subraster +int nrcols, nrlines #I size of the reference subraster +real image[ncols,nlines] #I the input image subraster +int ncols, nlines #I size of the image subraster +real xcor[xwindow,ywindow] #O the output cross-correlation function +int xwindow, ywindow #I size of the cross-correlation function + +int lagx, lagy, i, j +real meanr, facr, meani, faci, sum +real asumr() +#real cxmin, cxmax + +begin + meanr = asumr (ref, nrcols * nrlines) / (nrcols * nrlines) + facr = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + facr = facr + (ref[i,j] - meanr) ** 2 + } + if (facr <= 0.0) + facr = 1.0 + else + facr = sqrt (facr) + + do lagy = 1, ywindow { + do lagx = 1, xwindow { + meani = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + meani = meani + image[i+lagx-1,j+lagy-1] + } + meani = meani / (nrcols * nrlines) + faci = 0.0 + sum = 0.0 + do j = 1, nrlines { + do i = 1, nrcols { + faci = faci + (image[i+lagx-1,j+lagy-1] - meani) ** 2 + sum = sum + (ref[i,j] - meanr) * + (image[i+lagx-1,j+lagy-1] - meani) + } + } + if (faci <= 0.0) + faci = 1.0 + else + faci = sqrt (faci) + xcor[lagx,lagy] = sum / facr / faci + } + } +end + + +# RG_XDIFF -- Compute the error function at each of several templates. + +procedure rg_xdiff (ref, nrcols, nrlines, image, ncols, nlines, xcor, xwindow, + ywindow) + +real ref[nrcols,nrlines] #I reference subraste +int nrcols, nrlines #I size of the reference subraster +real image[ncols,nlines] #I image subraster +int ncols, nlines #I size of image subraster +real xcor[xwindow,ywindow] #O crosscorrelation function +int xwindow, ywindow #I size of correlation function + +int lagx, lagy, i, j +real meanr, meani, sum, cormin, cormax +real asumr() + + +begin + meanr = asumr (ref, nrcols * nrlines) / (nrcols * nrlines) + do lagy = 1, ywindow { + do lagx = 1, xwindow { + meani = 0.0 + do j = 1, nrlines { + do i = 1, nrcols + meani = meani + image[i+lagx-1,j+lagy-1] + } + meani = meani / (nrcols * nrlines) + sum = 0.0 + do j = 1, nrlines { + do i = 1, nrcols { + sum = sum + abs ((ref[i,j] - meanr) - + (image[i+lagx-1,j+lagy-1] - meani)) + } + } + xcor[lagx,lagy] = sum + } + } + + call alimr (xcor, xwindow * ywindow, cormin, cormax) + call adivkr (xcor, cormax, xcor, xwindow * ywindow) + call asubkr (xcor, 1.0, xcor, xwindow * ywindow) + call anegr (xcor, xcor, xwindow * ywindow) +end + diff --git a/pkg/images/immatch/src/xregister/rgxdbio.x b/pkg/images/immatch/src/xregister/rgxdbio.x new file mode 100644 index 00000000..3e197636 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxdbio.x @@ -0,0 +1,290 @@ +include "xregister.h" + +# RG_XWREC -- Procedure to write out the whole record. + +procedure rg_xwrec (db, dformat, xc) + +pointer db #I pointer to the database file +int dformat #I is the shifts file in database format +pointer xc #I pointer to the cross correlation structure + +int i, nregions, ngood, c1, c2, l1, l2, xlag, ylag +pointer sp, image, prc1, prc2, prl1, prl2, pxshift, pyshift +real xin, yin, xout, yout, xavshift, yavshift +int rg_xstati() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Write the header record. + if (dformat == YES) + call rg_xdbparams (db, xc) + + # Fetch the pointers to the columns. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + xavshift = 0.0 + yavshift = 0.0 + ngood = 0 + do i = 1, nregions { + + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + if (IS_INDEFR(Memr[pxshift+i-1]) || IS_INDEFR(Memr[pyshift+i-1])) { + if (dformat == YES) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + INDEFR, INDEFR) + } else { + if (dformat == YES) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + Memr[pxshift+i-1], Memr[pyshift+i-1]) + ngood = ngood + 1 + xavshift = xavshift + Memr[pxshift+i-1] + yavshift = yavshift + Memr[pyshift+i-1] + } + } + + # Compute the average shift. + if (ngood <= 0) { + xavshift = 0.0 + yavshift = 0.0 + } else { + xavshift = xavshift / ngood + yavshift = yavshift / ngood + } + call rg_xsetr (xc, TXSHIFT, xavshift) + call rg_xsetr (xc, TYSHIFT, yavshift) + + if (dformat == YES) + call rg_xdbshift (db, xc) + else { + call rg_xstats (xc, IMAGE, Memc[image], SZ_FNAME) + call fprintf (db, "%s %g %g\n") + call pargstr (Memc[image]) + call pargr (xavshift) + call pargr (yavshift) + } + + call sfree (sp) +end + + +# RG_XDBPARAMS -- Write the cross-correlation parameters to the database file. + +procedure rg_xdbparams (db, xc) + +pointer db #I pointer to the database file +pointer xc #I pointer to the cross-correlation structure + +pointer sp, str +int rg_xstati() +#real rg_xstatr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Write out the time record was written. + call dtput (db, "\n") + call dtptime (db) + + # Write out the record name. + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call dtput (db, "begin\t%s\n") + call pargstr (Memc[str]) + + # Write the image names. + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t\t%s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call dtput (db, "\t%s\t%s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + + call dtput (db, "\t%s\t%d\n") + call pargstr (KY_NREGIONS) + call pargi (rg_xstati (xc, NREGIONS)) + + call sfree (sp) +end + + +# RG_XWREG -- Write out the results for each region individually into +# the shifts file. + +procedure rg_xwreg (db, xc) + +pointer db #I pointer to the database file +pointer xc #I pointer to the cross-correlation structure + +int i, nregions, c1, c2, l1, l2, xlag, ylag +pointer prc1, prc2, prl1, prl2, pxshift, pyshift +real xin, yin, xout, yout +int rg_xstati() +pointer rg_xstatp() + +begin + # Fetch the regions pointers. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + pxshift = rg_xstatp (xc, XSHIFTS) + pyshift = rg_xstatp (xc, YSHIFTS) + nregions = rg_xstati (xc, NREGIONS) + + # Write out the reference image region(s) and the equivalent + # input image regions. + do i = 1, nregions { + + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + if (IS_INDEFR(Memr[pxshift+i-1]) || IS_INDEFR(Memr[pyshift+i-1])) + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + INDEFR, INDEFR) + else + call rg_xdbshiftr (db, Memi[prc1+i-1], Memi[prc2+i-1], + Memi[prl1+i-1], Memi[prl2+i-1], c1, c2, l1, l2, + Memr[pxshift+i-1], Memr[pyshift+i-1]) + } +end + + +# RG_XDBSHIFTR -- Write out the reference image section, input image +# section and x and y shifts for each region. + +procedure rg_xdbshiftr (db, rc1, rc2, rl1, rl2, c1, c2, l1, l2, xshift, yshift) + +pointer db #I pointer to the database file +int rc1, rc2 #I reference region column limits +int rl1, rl2 #I reference region line limits +int c1, c2 #I image region column limits +int l1, l2 #I image region line limits +real xshift #I x shift +real yshift #I y shift + +begin + call dtput (db,"\t[%d:%d,%d:%d]\t[%d:%d,%d:%d]\t%g\t%g\n") + call pargi (rc1) + call pargi (rc2) + call pargi (rl1) + call pargi (rl2) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargr (xshift) + call pargr (yshift) +end + + +# RG_XDBSHIFT -- Write the average shifts to the shifts database. + +procedure rg_xdbshift (db, xc) + +pointer db #I pointer to text database file +pointer xc #I pointer to the cross-correlation structure + +real rg_xstatr() + +begin + call dtput (db, "\t%s\t\t%g\n") + call pargstr (KY_TXSHIFT) + call pargr (rg_xstatr (xc, TXSHIFT)) + call dtput (db, "\t%s\t\t%g\n") + call pargstr (KY_TYSHIFT) + call pargr (rg_xstatr (xc, TYSHIFT)) +end + + +# RG_XPWREC -- Print the computed shift for a region. + +procedure rg_xpwrec (xc, i) + +pointer xc #I pointer to the cross-correlation structure +int i #I the current region + +int xlag, ylag, c1, c2, l1, l2 +pointer prc1, prc2, prl1, prl2 +real xin, yin, rxlag, rylag +int rg_xstati() +pointer rg_xstatp() + +begin + # Fetch the pointers to the reference regions. + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + + # Transform the reference region to the input region. + xin = (Memi[prc1+i-1] + Memi[prc2+i-1]) / 2.0 + yin = (Memi[prl1+i-1] + Memi[prl2+i-1]) / 2.0 + if (rg_xstati (xc, NREFPTS) > 0) { + call rg_etransform (xc, xin, yin, rxlag, rylag) + xlag = rxlag - xin + ylag = rylag - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + + c1 = Memi[prc1+i-1] + xlag + c2 = Memi[prc2+i-1] + xlag + l1 = Memi[prl1+i-1] + ylag + l2 = Memi[prl2+i-1] + ylag + + # Print the results. + call printf ("Region %d: [%d:%d,%d:%d] [%d:%d,%d:%d] %g %g\n") + call pargi (i) + call pargi (Memi[prc1+i-1]) + call pargi (Memi[prc2+i-1]) + call pargi (Memi[prl1+i-1]) + call pargi (Memi[prl2+i-1]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargr (Memr[rg_xstatp(xc,XSHIFTS)+i-1]) + call pargr (Memr[rg_xstatp(xc,YSHIFTS)+i-1]) +end diff --git a/pkg/images/immatch/src/xregister/rgxfft.x b/pkg/images/immatch/src/xregister/rgxfft.x new file mode 100644 index 00000000..8847cf56 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxfft.x @@ -0,0 +1,179 @@ +# RG_FFTCOR -- Compute the FFT of the reference and image data, take their +# product, and compute the inverse transform to get the cross-correlation +# function. The reference and input image are loaded into alternate memory +# locations. + +procedure rg_fftcor (fft, nxfft nyfft) + +real fft[ARB] #I/O array to be fft'd +int nxfft, nyfft #I dimensions of the fft + +pointer sp, dim + +begin + call smark (sp) + call salloc (dim, 2, TY_INT) + + # Fourier transform the two arrays. + Memi[dim] = nxfft + Memi[dim+1] = nyfft + if (Memi[dim+1] == 1) + call rg_fourn (fft, Memi[dim], 1, 1) + else + call rg_fourn (fft, Memi[dim], 2, 1) + + # Compute the product of the two transforms. + call rg_mulfft (fft, fft, 2 * nxfft, nyfft) + + # Shift the array to center the transform. + call rg_fshift (fft, fft, 2 * nxfft, nyfft) + + # Normalize the transform. + call adivkr (fft, real (nxfft * nyfft), fft, 2 * nxfft * nyfft) + + # Compute the inverse transform. + if (Memi[dim+1] == 1) + call rg_fourn (fft, Memi[dim], 1, -1) + else + call rg_fourn (fft, Memi[dim], 2, -1) + + call sfree (sp) +end + + +# RG_MULFFT -- Unpack the two individual ffts and compute their product. + +procedure rg_mulfft (fft1, fft2, nxfft, nyfft) + +real fft1[nxfft,nyfft] #I array containing 2 ffts of 2 real functions +real fft2[nxfft,nyfft] #O fft of correlation function +int nxfft, nyfft #I dimensions of fft + +int i,j, nxd2p2, nxp2, nxp3, nyd2p1, nyp2 +real c1, c2, h1r, h1i, h2r, h2i + +begin + c1 = 0.5 + c2 = -0.5 + + nxd2p2 = nxfft / 2 + 2 + nxp2 = nxfft + 2 + nxp3 = nxfft + 3 + nyd2p1 = nyfft / 2 + 1 + nyp2 = nyfft + 2 + + # Compute the 0 frequency point. + h1r = fft1[1,1] + h1i = 0.0 + h2r = fft1[2,1] + h2i = 0.0 + fft2[1,1] = h1r * h2r + fft2[2,1] = 0.0 + + # Compute the x axis points. + do i = 3, nxd2p2, 2 { + h2r = c1 * (fft1[i,1] + fft1[nxp2-i,1]) + h2i = c1 * (fft1[i+1,1] - fft1[nxp3-i,1]) + h1r = -c2 * (fft1[i+1,1] + fft1[nxp3-i,1]) + h1i = c2 * (fft1[i,1] - fft1[nxp2-i,1]) + fft2[i,1] = (h1r * h2r + h1i * h2i) + fft2[i+1,1] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,1] = fft2[i,1] + fft2[nxp3-i,1] = - fft2[i+1,1] + } + + # Quit if the transform is 1D. + if (nyfft < 2) + return + + # Compute the y axis points. + do i = 2, nyd2p1 { + h2r = c1 * (fft1[1,i] + fft1[1, nyp2-i]) + h2i = c1 * (fft1[2,i] - fft1[2,nyp2-i]) + h1r = -c2 * (fft1[2,i] + fft1[2,nyp2-i]) + h1i = c2 * (fft1[1,i] - fft1[1,nyp2-i]) + fft2[1,i] = (h1r * h2r + h1i * h2i) + fft2[2,i] = (h1i * h2r - h2i * h1r) + fft2[1,nyp2-i] = fft2[1,i] + fft2[2,nyp2-i] = - fft2[2,i] + } + + # Compute along the axis of symmetry. + do i = 3, nxd2p2, 2 { + h2r = c1 * (fft1[i,nyd2p1] + fft1[nxp2-i, nyd2p1]) + h2i = c1 * (fft1[i+1,nyd2p1] - fft1[nxp3-i,nyd2p1]) + h1r = -c2 * (fft1[i+1,nyd2p1] + fft1[nxp3-i,nyd2p1]) + h1i = c2 * (fft1[i,nyd2p1] - fft1[nxp2-i,nyd2p1]) + fft2[i,nyd2p1] = (h1r * h2r + h1i * h2i) + fft2[i+1,nyd2p1] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,nyd2p1] = fft2[i,nyd2p1] + fft2[nxp3-i,nyd2p1] = - fft2[i+1,nyd2p1] + } + + # Compute the remainder of the transform. + do j = 2, nyd2p1 - 1 { + do i = 3, nxfft, 2 { + h2r = c1 * (fft1[i,j] + fft1[nxp2-i, nyp2-j]) + h2i = c1 * (fft1[i+1,j] - fft1[nxp3-i,nyp2-j]) + h1r = -c2 * (fft1[i+1,j] + fft1[nxp3-i,nyp2-j]) + h1i = c2 * (fft1[i,j] - fft1[nxp2-i,nyp2-j]) + fft2[i,j] = (h1r * h2r + h1i * h2i) + fft2[i+1,j] = (h1i * h2r - h2i * h1r) + fft2[nxp2-i,nyp2-j] = fft2[i,j] + fft2[nxp3-i,nyp2-j] = - fft2[i+1,j] + } + } +end + + +# RG_FNORM -- Normalize the reference and image data before computing +# the fft's. + +procedure rg_fnorm (array, ncols, nlines, nxfft, nyfft) + +real array[ARB] #I/O the input/output data array +int ncols, nlines #I dimensions of the input data array +int nxfft, nyfft #I dimensions of the fft + +int i, j, index +real sumr, sumi, meanr, meani + +begin + # Compute the mean. + sumr = 0.0 + sumi = 0.0 + index = 0 + do j = 1, nlines { + do i = 1, ncols { + sumr = sumr + array[index+2*i-1] + sumi = sumi + array[index+2*i] + } + index = index + 2 * nxfft + } + meanr = sumr / (ncols * nlines) + meani = sumi / (ncols * nlines) + + # Compute the sigma. + sumr = 0.0 + sumi = 0.0 + index = 0 + do j = 1, nlines { + do i = 1, ncols { + sumr = sumr + (array[index+2*i-1] - meanr) ** 2 + sumi = sumi + (array[index+2*i] - meani) ** 2 + } + index = index + 2 * nxfft + } + sumr = sqrt (sumr) + sumi = sqrt (sumi) + + # Normalize the data. + index = 0 + do j = 1, nlines { + do i = 1, ncols { + array[index+2*i-1] = (array[index+2*i-1] - meanr) / sumr + array[index+2*i] = (array[index+2*i] - meani) / sumi + } + index = index + 2 * nxfft + } +end diff --git a/pkg/images/immatch/src/xregister/rgxfit.x b/pkg/images/immatch/src/xregister/rgxfit.x new file mode 100644 index 00000000..34e6398c --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxfit.x @@ -0,0 +1,814 @@ +include +include +include +include "xregister.h" + +define NL_MAXITER 10 +define NL_TOL 0.001 + +# RG_FIT -- Fit the peak of the cross-correlation function using one of the +# fitting functions. + +procedure rg_fit (xc, nreg, gd, xshift, yshift) + +pointer xc #I the pointer to the cross-corrrelation structure +int nreg #I the current region +pointer gd #I the pointer to the graphics stream +real xshift, yshift #O the computed shifts + +int nrlines, xwindow, ywindow, xcbox, ycbox, xlag, ylag +real xin, yin, xout, yout +int rg_xstati() +pointer rg_xstatp() + +begin + # Check the window and centering box sizes. + nrlines = Memi[rg_xstatp(xc,RL2)+nreg-1] - + Memi[rg_xstatp(xc,RL1)+nreg-1] + 1 + xwindow = rg_xstati (xc, XWINDOW) + if (nrlines == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + xcbox = rg_xstati (xc, XCBOX) + if (nrlines == 1) + ycbox = 1 + else + ycbox = rg_xstati (xc, YCBOX) + + # Do the centering. + switch (rg_xstati (xc, PFUNC)) { + case XC_PNONE: + call rg_maxmin (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xshift, yshift) + case XC_CENTROID: + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + case XC_SAWTOOTH: + call rg_sawtooth (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + case XC_PARABOLA: + call rg_iparabolic (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xcbox, ycbox, xshift, yshift) + case XC_MARK: + if (gd == NULL) + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, + ywindow, xcbox, ycbox, xshift, yshift) + else + call rg_xmkpeak (gd, xwindow, ywindow, xshift, yshift) + default: + call rg_imean (Memr[rg_xstatp(xc,XCOR)], xwindow, ywindow, + xcbox, ycbox, xshift, yshift) + } + + # Store the shifts. + if (rg_xstati (xc, NREFPTS) > 0) { + xin = (Memi[rg_xstatp(xc,RC1)+nreg-1] + + Memi[rg_xstatp(xc,RC2)+nreg-1]) / 2.0 + yin = (Memi[rg_xstatp(xc,RL1)+nreg-1] + + Memi[rg_xstatp(xc,RL2)+nreg-1]) / 2.0 + call rg_etransform (xc, xin, yin, xout, yout) + xlag = xout - xin + ylag = yout - yin + } else { + xlag = rg_xstati (xc, XLAG) + ylag = rg_xstati (xc, YLAG) + } + xshift = - (xshift + xlag) + yshift = - (yshift + ylag) + Memr[rg_xstatp(xc,XSHIFTS)+nreg-1] = xshift + Memr[rg_xstatp(xc,YSHIFTS)+nreg-1] = yshift +end + + +# RG_MAXMIN -- Procedure to compute the peak of the cross-correlation function +# by determining the maximum point. + +procedure rg_maxmin (xcor, xwindow, ywindow, xshift, yshift) + +real xcor[xwindow,ywindow] #I the cross-correlation function +int xwindow, ywindow #I dimensions of cross-correlation function +real xshift, yshift #O x and shift of the peak + +int xindex, yindex + +begin + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + xshift = xindex - (1.0 + xwindow) / 2.0 + yshift = yindex - (1.0 + ywindow) / 2.0 +end + + +# RG_IMEAN -- Compute the peak of the cross-correlation function using the +# intensity weighted mean of the marginal distributions in x and y. + +procedure rg_imean (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation function +int xcbox, ycbox #I dimensions of the centering box +real xshift, yshift #O x and y shift of cross-correlation function + +int xindex, yindex, xlo, xhi, ylo, yhi, nx, ny +pointer sp, xmarg, ymarg + +begin + call smark (sp) + call salloc (xmarg, xcbox, TY_REAL) + call salloc (ymarg, ycbox, TY_REAL) + + # Locate the maximum point and normalize. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + # Compute the limits of the centering box. + xlo = max (1, xindex - xcbox / 2) + xhi = min (xwindow, xindex + xcbox / 2) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox / 2) + yhi = min (ywindow, yindex + ycbox / 2) + ny = yhi - ylo + 1 + + # Accumulate the marginals. + call rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, + Memr[xmarg], Memr[ymarg]) + + # Compute the shifts. + call rg_centroid (Memr[xmarg], nx, xshift) + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + call rg_centroid (Memr[ymarg], ny, yshift) + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + + +# RG_IPARABOLIC -- Computer the peak of the cross-correlation function by +# doing parabolic interpolation around the peak. + +procedure rg_iparabolic (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation fucntion +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shift of the peak + +int i, j, xindex, yindex, xlo, xhi, nx, ylo, yhi, ny +pointer sp, x, y, c, xfit, yfit + +begin + # Allocate working space. + call smark (sp) + call salloc (x, 3, TY_REAL) + call salloc (y, 3, TY_REAL) + call salloc (c, 3, TY_REAL) + call salloc (xfit, 3, TY_REAL) + call salloc (yfit, 3, TY_REAL) + + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - 1) + xhi = min (xwindow, xindex + 1) + nx = xhi - xlo + 1 + ylo = max (1, yindex - 1) + yhi = min (ywindow, yindex + 1) + ny = yhi - ylo + 1 + + # Initialize. + do i = 1, 3 + Memr[x+i-1] = i + + # Fit the x shift. + if (nx >= 3) { + do j = ylo, yhi { + do i = xlo, xhi + Memr[y+i-xlo] = xcor[i,j] + call rg_iparab (Memr[x], Memr[y], Memr[c]) + Memr[xfit+j-ylo] = - Memr[c+1] / (2.0 * Memr[c+2]) + Memr[yfit+j-ylo] = Memr[c] + Memr[c+1] * Memr[xfit+j-ylo] + + Memr[c+2] * Memr[xfit+j-ylo] ** 2 + } + if (ny >= 3) + call rg_iparab (Memr[xfit], Memr[yfit], Memr[c]) + xshift = - Memr[c+1] / (2.0 * Memr[c+2]) + } else + xshift = xindex - xlo + 1 + + # Fit the y shift. + if (ny >= 3) { + do i = xlo, xhi { + do j = ylo, yhi + Memr[y+j-ylo] = xcor[i,j] + call rg_iparab (Memr[x], Memr[y], Memr[c]) + Memr[xfit+i-xlo] = - Memr[c+1] / (2.0 * Memr[c+2]) + Memr[yfit+i-xlo] = Memr[c] + Memr[c+1] * Memr[xfit+i-xlo] + + Memr[c+2] * Memr[xfit+i-xlo] ** 2 + } + call rg_iparab (Memr[xfit], Memr[yfit], Memr[c]) + yshift = - Memr[c+1] / (2.0 * Memr[c+2]) + } else + yshift = yindex - ylo + 1 + + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + + +define NPARS_PARABOLA 3 + +# RG_PARABOLIC -- Compute the peak of the cross-correlation function by fitting +# a parabola to the peak. + +procedure rg_parabolic (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of the cross-correlation fucntion +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shift of the peak + +extern rg_polyfit, rg_dpolyfit +int i, xindex, yindex, xlo, xhi, ylo, yhi, nx, ny, npar, ier +pointer sp, x, w, xmarg, ymarg, params, eparams, list, nl +int locpr() + +begin + call smark (sp) + call salloc (x, max (xwindow, ywindow), TY_REAL) + call salloc (w, max (xwindow, ywindow), TY_REAL) + call salloc (xmarg, max (xwindow, ywindow), TY_REAL) + call salloc (ymarg, max (xwindow, ywindow), TY_REAL) + call salloc (params, NPARS_PARABOLA, TY_REAL) + call salloc (eparams, NPARS_PARABOLA, TY_REAL) + call salloc (list, NPARS_PARABOLA, TY_INT) + + # Locate the maximum point. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - xcbox / 2) + xhi = min (xwindow, xindex + xcbox / 2) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox / 2) + yhi = min (ywindow, yindex + ycbox / 2) + ny = yhi - ylo + 1 + + # Accumulate the marginals. + call rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, + Memr[xmarg], Memr[ymarg]) + + # Compute the x shift. + if (nx >= 3) { + do i = 1, nx + Memr[x+i-1] = i + do i = 1, nx + Memr[w+i-1] = Memr[xmarg+i-1] + call rg_iparab (Memr[x+xindex-xlo-1], Memr[xmarg+xindex-xlo-1], + Memr[params]) + xshift = - Memr[params+1] / (2.0 * Memr[params+2]) + call eprintf ("\txshift=%g\n") + call pargr (xshift) + call aclrr (Memr[eparams], NPARS_PARABOLA) + do i = 1, NPARS_PARABOLA + Memi[list+i-1] = i + call nlinitr (nl, locpr (rg_polyfit), locpr (rg_dpolyfit), + Memr[params], Memr[eparams], NPARS_PARABOLA, Memi[list], + NPARS_PARABOLA, .0001, NL_MAXITER) + call nlfitr (nl, Memr[x], Memr[xmarg], Memr[w], nx, 1, WTS_USER, + ier) + call nlvectorr (nl, Memr[x], Memr[w], nx, 1) + do i = 1, nx { + call eprintf ("x=%g y=%g yfit=%g\n") + call pargr (Memr[x+i-1]) + call pargr (Memr[xmarg+i-1]) + call pargr (Memr[w+i-1]) + } + if (ier != NO_DEG_FREEDOM) { + call nlpgetr (nl, Memr[params], npar) + if (Memr[params+2] != 0) + xshift = - Memr[params+1] / (2.0 * Memr[params+2]) + else + xshift = xindex - xlo + 1 + } else + xshift = xindex - xlo + 1 + call nlfreer (nl) + } else + xshift = xindex - xlo + 1 + + # Compute the y shift. + if (ny >= 3) { + do i = 1, ny + Memr[x+i-1] = i + do i = 1, ny + Memr[w+i-1] = Memr[ymarg+i-1] + call rg_iparab (Memr[x+yindex-ylo-1], Memr[ymarg+yindex-ylo-1], + Memr[params]) + yshift = - Memr[params+1] / (2.0 * Memr[params+2]) + call eprintf ("\tyshift=%g\n") + call pargr (yshift) + call aclrr (Memr[eparams], NPARS_PARABOLA) + do i = 1, NPARS_PARABOLA + Memi[list+i-1] = i + call nlinitr (nl, locpr (rg_polyfit), locpr (rg_dpolyfit), + Memr[params], Memr[eparams], NPARS_PARABOLA, Memi[list], + NPARS_PARABOLA, 0.0001, NL_MAXITER) + call nlfitr (nl, Memr[x], Memr[ymarg], Memr[w], ny, 1, WTS_USER, + ier) + call nlvectorr (nl, Memr[x], Memr[w], ny, 1) + do i = 1, ny { + call eprintf ("x=%g y=%g yfit=%g\n") + call pargr (Memr[x+i-1]) + call pargr (Memr[ymarg+i-1]) + call pargr (Memr[w+i-1]) + } + if (ier != NO_DEG_FREEDOM) { + call nlpgetr (nl, Memr[params], npar) + if (Memr[params+2] != 0) + yshift = -Memr[params+1] / (2.0 * Memr[params+2]) + else + yshift = yindex - ylo + 1 + } else + yshift = yindex - ylo + 1 + call nlfreer (nl) + } else + yshift = yindex - ylo + 1 + + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + call sfree (sp) +end + +define EMISSION 1 # emission features +define ABSORPTION 2 # emission features + +# RG_SAWTOOTH -- Compute the the x and y centers using a sawtooth +# convolution function. + +procedure rg_sawtooth (xcor, xwindow, ywindow, xcbox, ycbox, xshift, yshift) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I the dimensions of the cross-correlation +int xcbox, ycbox #I the dimensions of the centering box +real xshift, yshift #O the x and y shifts + +int i, j, xindex, yindex, xlo, xhi, ylo, yhi, nx, ny +pointer sp, data, xfit, yfit, yclean +real ic + +begin + call smark (sp) + call salloc (data, max (xwindow, ywindow), TY_REAL) + call salloc (xfit, max (xwindow, ywindow), TY_REAL) + call salloc (yfit, max (xwindow, ywindow), TY_REAL) + call salloc (yclean, max (xwindow, ywindow), TY_REAL) + + # Locate the maximum point and normalize. + call rg_alim2r (xcor, xwindow, ywindow, xindex, yindex) + + xlo = max (1, xindex - xcbox) + xhi = min (xwindow, xindex + xcbox) + nx = xhi - xlo + 1 + ylo = max (1, yindex - ycbox) + yhi = min (ywindow, yindex + ycbox) + ny = yhi - ylo + 1 + + # Compute the y shift. + if (ny >= 3) { + do j = ylo, yhi { + do i = xlo, xhi + Memr[data+i-xlo] = xcor[i,j] + call rg_x1dcenter (real (xindex - xlo + 1), Memr[data], nx, + Memr[xfit+j-ylo], Memr[yfit+j-ylo], real (nx / 2.0), + EMISSION, real (nx / 2.0), 0.0) + } + call arbpix (Memr[yfit], Memr[yclean], ny, II_SPLINE3, + II_BOUNDARYEXT) + call rg_x1dcenter (real (yindex - ylo + 1), Memr[yclean], ny, + yshift, ic, real (ny / 2.0), EMISSION, real (ny / 2.0), 0.0) + if (IS_INDEFR(yshift)) + yshift = yindex - ylo + 1 + } else + yshift = yindex - ylo + 1 + yshift = yshift + ylo - 1 - (1.0 + ywindow) / 2.0 + + # Compute the x shift. + if (nx >= 3) { + if (ny >= 3) { + do i = xlo, xhi { + do j = ylo, yhi + Memr[data+j-ylo] = xcor[i,j] + call rg_x1dcenter (real (yindex - ylo + 1), Memr[data], ny, + Memr[xfit+i-xlo], Memr[yfit+i-xlo], real (ny / 2.0), + EMISSION, real (ny / 2.0), 0.0) + } + call arbpix (Memr[yfit], Memr[yclean], nx, II_SPLINE3, + II_BOUNDARYEXT) + call rg_x1dcenter (real (xindex - xlo + 1), Memr[yclean], nx, + xshift, ic, real (nx / 2.0), EMISSION, real (nx / 2.0), 0.0) + } else { + call rg_x1dcenter (real (xindex - xlo + 1), xcor[xlo,1], nx, + xshift, ic, real (nx / 2.0), EMISSION, real (nx / 2.0), 0.0) + } + if (IS_INDEFR(xshift)) + xshift = xindex - xlo + 1 + } else + xshift = xindex - xlo + 1 + xshift = xshift + xlo - 1 - (1.0 + xwindow) / 2.0 + + call sfree (sp) +end + + +# RG_ALIM2R -- Determine the pixel position of the data maximum. + +procedure rg_alim2r (data, nx, ny, i, j) + +real data[nx,ARB] #I the input data +int nx, ny #I the dimensions of the input array +int i, j #O the indices of the maximum pixel + +int ii, jj +real datamax + +begin + datamax = -MAX_REAL + do jj = 1, ny { + do ii = 1, nx { + if (data[ii,jj] > datamax) { + datamax = data[ii,jj] + i = ii + j = jj + } + } + } +end + + +# RG_XMKMARG -- Acumulate the marginal arrays in x and y. + +procedure rg_xmkmarg (xcor, xwindow, ywindow, xlo, xhi, ylo, yhi, xmarg, + ymarg) + +real xcor[xwindow,ARB] #I the cross-correlation function +int xwindow, ywindow #I dimensions of cross-correlation function +int xlo, xhi #I the x limits for centering +int ylo, yhi #I the y limits for centering +real xmarg[ARB] #O the output x marginal array +real ymarg[ARB] #O the output y marginal array + +int i, j, index, nx, ny + +begin + nx = xhi - xlo + 1 + ny = yhi - ylo + 1 + + # Compute the x marginal. + index = 1 - xlo + do i = xlo, xhi { + xmarg[index+i] = 0.0 + do j = ylo, yhi + xmarg[index+i] = xmarg[index+i] + xcor[i,j] + } + + # Normalize the x marginal. + call adivkr (xmarg, real (ny), xmarg, nx) + + # Compute the y marginal. + index = 1 - ylo + do j = ylo, yhi { + ymarg[index+j] = 0.0 + do i = xlo, xhi + ymarg[index+j] = ymarg[index+j] + xcor[i,j] + } + + # Normalize the ymarginal. + call adivkr (ymarg, real (nx), ymarg, ny) +end + + +# RG_CENTROID -- Compute the intensity weighted maximum of an array. + +procedure rg_centroid (a, npts, shift) + +real a[ARB] #I the input array +int npts #I the number of points +real shift #O the position of the maximum + +int i +real mean, dif, sumi, sumix +bool fp_equalr() +real asumr() + +begin + sumi = 0.0 + sumix = 0.0 + mean = asumr (a, npts) / npts + + do i = 1, npts { + dif = a[i] + dif = a[i] - mean + if (dif < 0.0) + next + sumi = sumi + dif + sumix = sumix + i * dif + } + + if (fp_equalr (sumi, 0.0)) + shift = (1.0 + npts) / 2.0 + else + shift = sumix / sumi +end + + +define MIN_WIDTH 3. # minimum centering width +define EPSILON 0.001 # accuracy of centering +define EPSILON1 0.005 # tolerance for convergence check +define ITERATIONS 100 # maximum number of iterations +define MAX_DXCHECK 3 # look back for failed convergence +define INTERPTYPE II_SPLINE3 # image interpolation type + + +# RG_X1DCENTER -- Locate the center of a one dimensional feature. +# A value of INDEF is returned in the centering fails for any reason. +# This procedure just sets up the data and adjusts for emission or +# absorption features. The actual centering is done by C1D_CENTER. + +procedure rg_x1dcenter (x, data, npts, xc, ic, width, type, radius, threshold) + +real x #I initial guess +real data[npts] #I data points +int npts #I number of data points +real xc #O computed center +real ic #O intensity at computed center +real width #I feature width +int type #I feature type +real radius #I centering radius +real threshold #I minimum range in feature + +int x1, x2, nx +real a, b, rad, wid +pointer sp, data1 + +begin + # Check starting value. + if (IS_INDEF(x) || (x < 1) || (x > npts)) { + xc = INDEF + ic = INDEF + return + } + + # Set minimum width and error radius. The minimum in the error radius + # is for defining the data window. The user error radius is used to + # check for an error in the derived center at the end of the centering. + + wid = max (width, MIN_WIDTH) + rad = max (2., radius) + + # Determine the pixel value range around the initial center, including + # the width and error radius buffer. Check for a minimum range. + + x1 = max (1., x - wid / 2 - rad - wid) + x2 = min (real (npts), x + wid / 2 + rad + wid + 1) + nx = x2 - x1 + 1 + call alimr (data[x1], nx, a, b) + if (b - a < threshold) { + xc = INDEF + ic = INDEF + return + } + + # Allocate memory for the continuum subtracted data vector. The X + # range is just large enough to include the error radius and the + # half width. + + x1 = max (1., x - wid / 2 - rad) + x2 = min (real (npts), x + wid / 2 + rad + 1) + nx = x2 - x1 + 1 + + call smark (sp) + call salloc (data1, nx, TY_REAL) + call amovr (data[x1], Memr[data1], nx) + + # Make the centering data positive, subtract the continuum, and + # apply a threshold to eliminate noise spikes. + + switch (type) { + case EMISSION: + a = 0. + call asubkr (data[x1], a + threshold, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + case ABSORPTION: + call anegr (data[x1], Memr[data1], nx) + call asubkr (Memr[data1], threshold - b, Memr[data1], nx) + call amaxkr (Memr[data1], 0., Memr[data1], nx) + default: + call error (0, "Unknown feature type") + } + + # Determine the center. + call rg_xcenter (x - x1 + 1, Memr[data1], nx, xc, ic, wid) + + # Check user centering error radius. + if (!IS_INDEF(xc)) { + xc = xc + x1 - 1 + if (abs (x - xc) > radius) { + xc = INDEF + ic = INDEF + } + } + + # Free memory and return the center position. + call sfree (sp) +end + + +# RG_XCENTER -- One dimensional centering algorithm. + +procedure rg_xcenter (x, data, npts, xc, ic, width) + +real x #I starting guess +int npts #I number of points in data vector +real data[npts] #I data vector +real xc #O computed xc +real ic #O computed intensity at xc +real width #I centering width + +int i, j, iteration, dxcheck +real hwidth, dx, dxabs, dxlast +real a, b, sum1, sum2, intgrl1, intgrl2 +pointer asi1, asi2, sp, data1 + +real asigrl(), asieval() + +define done_ 99 + +begin + # Find the nearest local maxima as the starting point. + # This is required because the threshold limit may have set + # large regions of the data to zero and without a gradient + # the centering will fail. + + i = x + for (i=x+.5; (i1) && (data[j]<=data[j-1]); j=j-1) + ; + + if (i-x < x-j) + xc = i + else + xc = j + + # Check data range. + hwidth = width / 2 + if ((xc - hwidth < 1) || (xc + hwidth > npts)) { + xc = INDEF + ic = INDEF + return + } + + # Set interpolation functions. + call asiinit (asi1, INTERPTYPE) + call asiinit (asi2, INTERPTYPE) + call asifit (asi1, data, npts) + + # Allocate, compute, and interpolate the x*y values. + call smark (sp) + call salloc (data1, npts, TY_REAL) + do i = 1, npts + Memr[data1+i-1] = data[i] * i + call asifit (asi2, Memr[data1], npts) + call sfree (sp) + + # Iterate to find center. This loop exits when 1) the maximum + # number of iterations is reached, 2) the delta is less than + # the required accuracy (criterion for finding a center), 3) + # there is a problem in the computation, 4) successive steps + # continue to exceed the minimum delta. + + dxlast = 1. + do iteration = 1, ITERATIONS { + + # Triangle centering function. + a = xc - hwidth + b = xc - hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = (xc - hwidth) * intgrl1 - intgrl2 + sum2 = -intgrl1 + a = b + b = xc + hwidth / 2 + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 - xc * intgrl1 + intgrl2 + sum2 = sum2 + intgrl1 + a = b + b = xc + hwidth + intgrl1 = asigrl (asi1, a, b) + intgrl2 = asigrl (asi2, a, b) + sum1 = sum1 + (xc + hwidth) * intgrl1 - intgrl2 + sum2 = sum2 - intgrl1 + + # Return no center if sum2 is zero. + if (sum2 == 0.) + break + + # Limit dx change in one iteration to 1 pixel. + dx = max (-1., min (1., sum1 / abs (sum2))) + dxabs = abs (dx) + xc = xc + dx + ic = asieval (asi1, xc) + + # Check data range. Return no center if at edge of data. + if ((xc - hwidth < 1) || (xc + hwidth > npts)) + break + + # Convergence tests. + if (dxabs < EPSILON) + goto done_ + if (dxabs > dxlast + EPSILON1) { + dxcheck = dxcheck + 1 + if (dxcheck > MAX_DXCHECK) + break + } else { + dxcheck = 0 + dxlast = dxabs + } + } + + # If we get here then no center was found. + xc = INDEF + ic = INDEF + +done_ call asifree (asi1) + call asifree (asi2) +end + + +# RG_IPARAB -- Compute the coefficients of the parabola through three +# evenly spaced points. + +procedure rg_iparab (x, y, c) + +real x[NPARS_PARABOLA] #I input x values +real y[NPARS_PARABOLA] #I input y values +real c[NPARS_PARABOLA] #O computed coefficients + +begin + c[3] = (y[1]-y[2]) * (x[2]-x[3]) / (x[1]-x[2]) - (y[2]-y[3]) + c[3] = c[3] / ((x[1]**2-x[2]**2) * (x[2]-x[3]) / (x[1]-x[2]) - + (x[2]**2-x[3]**2)) + + c[2] = (y[1] - y[2]) - c[3] * (x[1]**2 - x[2]**2) + c[2] = c[2] / (x[1] - x[2]) + + c[1] = y[1] - c[2] * x[1] - c[3] * x[1]**2 +end + + +# RG_POLYFIT -- Evaluate an nth order polynomial. + +procedure rg_polyfit (x, nvars, p, np, z) + +real x #I position coordinate +int nvars #I number of variables +real p[ARB] #I coefficients of polynomial +int np #I number of parameters +real z #O function return + +int i +real r + +begin + r = 0.0 + do i = 2, np + r = r + x**(i-1) * p[i] + z = p[1] + r +end + + +# RG_DPOLYFIT -- Evaluate an nth order polynomial and its derivatives. + +procedure rg_dpolyfit (x, nvars, p, dp, np, z, der) + +real x #I position coordinate +int nvars #I number of variables +real p[ARB] #I coefficients of polynomial +real dp[ARB] #I parameter derivative increments +int np #I number of parameters +real z #O function value +real der[ARB] #O derivatives + +int i + +begin + der[1] = 1.0 + z = 0.0 + do i = 2, np { + der[i] = x ** (i-1) + z = z + x**(i-1) * p[i] + } + z = p[1] + z +end diff --git a/pkg/images/immatch/src/xregister/rgxgpars.x b/pkg/images/immatch/src/xregister/rgxgpars.x new file mode 100644 index 00000000..82943730 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxgpars.x @@ -0,0 +1,68 @@ +include "xregister.h" + +# RG_XGPARS -- Read in the XREGISTER task algorithm parameters. + +procedure rg_xgpars (xc) + +pointer xc #I pointer to the main structure + +int xlag, ylag, xwindow, ywindow, xcbox, ycbox +pointer sp, str +int clgwrd(), clgeti() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the correlation structure. + call rg_xinit (xc, clgwrd ("correlation", Memc[str], SZ_LINE, + XC_CTYPES)) + + # Fetch the initial shift information. + xlag = clgeti ("xlag") + ylag = clgeti ("ylag") + call rg_xseti (xc, IXLAG, xlag) + call rg_xseti (xc, IYLAG, ylag) + call rg_xseti (xc, XLAG, xlag) + call rg_xseti (xc, YLAG, ylag) + call rg_xseti (xc, DXLAG, clgeti ("dxlag")) + call rg_xseti (xc, DYLAG, clgeti ("dylag")) + + # Get the background value computation parameters. + call rg_xseti (xc, BACKGRD, clgwrd ("background", Memc[str], SZ_LINE, + XC_BTYPES)) + call rg_xsets (xc, BSTRING, Memc[str]) + call rg_xseti (xc, BORDER, clgeti ("border")) + call rg_xsetr (xc, LOREJECT, clgetr ("loreject")) + call rg_xsetr (xc, HIREJECT, clgetr ("hireject")) + call rg_xsetr (xc, APODIZE, clgetr ("apodize")) + call rg_xseti (xc, FILTER, clgwrd ("filter", Memc[str], SZ_LINE, + XC_FTYPES)) + call rg_xsets (xc, FSTRING, Memc[str]) + + # Get the window parameters and force the window size to be odd. + xwindow = clgeti ("xwindow") + if (mod (xwindow,2) == 0) + xwindow = xwindow + 1 + call rg_xseti (xc, XWINDOW, xwindow) + ywindow = clgeti ("ywindow") + if (mod (ywindow,2) == 0) + ywindow = ywindow + 1 + call rg_xseti (xc, YWINDOW, ywindow) + + # Get the peak fitting parameters. + call rg_xseti (xc, PFUNC, clgwrd ("function", Memc[str], SZ_LINE, + XC_PTYPES)) + xcbox = clgeti ("xcbox") + if (mod (xcbox,2) == 0) + xcbox = xcbox + 1 + call rg_xseti (xc, XCBOX, xcbox) + ycbox = clgeti ("ycbox") + if (mod (ycbox,2) == 0) + ycbox = ycbox + 1 + call rg_xseti (xc, YCBOX, ycbox) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxicorr.x b/pkg/images/immatch/src/xregister/rgxicorr.x new file mode 100644 index 00000000..e96c6dec --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxicorr.x @@ -0,0 +1,583 @@ +include +include +include +include "xregister.h" + +define HELPFILE "immatch$src/xregister/xregister.key" +define OHELPFILE "immatch$src/xregister/oxregister.key" + +define XC_PCONTOUR 1 +define XC_PLINE 2 +define XC_PCOL 3 + + +# RG_XICORR -- Compute the shifts for each image interactively using +# cross-correlation techniques. + +int procedure rg_xicorr (imr, im1, im2, db, dformat, reglist, tfd, xc, gd, id) + +pointer imr #I/O pointer to the reference image +pointer im1 #I/O pointer to the input image +pointer im2 #I/O pointer to the output image +pointer db #I/O pointer to the shifts database file +int dformat #I is the shifts file in database format +int reglist #I/O the regions list descriptor +int tfd #I/O the transform file descriptor +pointer xc #I pointer to the cross-corrrelation structure +pointer gd #I the graphics stream pointer +pointer id #I the display stream pointer + +int newdata, newcross, newcenter, wcs, key, cplottype, newplot +int ip, ncolr, nliner +pointer sp, cmd +real xshift, yshift, wx, wy +int rg_xstati(), rg_icross(), clgcur(), rg_xgtverify(), rg_xgqverify() +int ctoi() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Initialize. + newdata = YES + newcross = YES + newcenter = YES + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + cplottype = XC_PCONTOUR + newplot = YES + xshift = 0.0 + yshift = 0.0 + + # Compute the cross-correlation function for the first region + # and print the results. + if (rg_xstati (xc, NREGIONS) <= 0) { + call gclear (gd) + call printf ("The regions list is empty\n") + } else if (rg_icross (xc, imr, im1, rg_xstati (xc, CREGION)) != ERR) { + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_fit (xc, rg_xstati (xc, CREGION), gd, xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newdata = NO + newcross = NO + newcenter = NO + newplot = NO + } else { + call gclear (gd) + call printf ( + "Error computing X-correlation function for region %d\n") + call pargi (rg_xstati (xc, CREGION)) + } + + + # Loop over the cursor commands. + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != + EOF) { + + switch (key) { + + # Print the help page. + case '?': + call gpagefile (gd, HELPFILE, "") + + # Redraw the current plot. + case 'r': + newplot = YES + + # Draw a contour plot of the cross-correlation function. + case 'c': + if (cplottype != XC_PCONTOUR) + newplot = YES + ncolr = (rg_xstati (xc, XWINDOW) + 1) / 2 + nliner = (rg_xstati (xc, YWINDOW) + 1) / 2 + cplottype = XC_PCONTOUR + + # Plot a column of the cross-correlation function. + case 'x': + if (cplottype != XC_PCOL) + newplot = YES + if (cplottype == XC_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (cplottype == XC_PLINE) { + ncolr = nint (wx) + } + cplottype = XC_PCOL + + # Plot a line of the cross-correlation function. + case 'y': + if (cplottype != XC_PLINE) + newplot = YES + if (cplottype == XC_PCONTOUR) { + ncolr = nint (wx) + nliner = nint (wy) + } else if (cplottype == XC_PCOL) { + ncolr = nint (wx) + } + cplottype = XC_PLINE + + # Quit the task gracefully. + case 'q': + if (rg_xgqverify ("xregister", db, dformat, xc, key) == YES) { + call sfree (sp) + return (rg_xgtverify (key)) + } + + # The Data overlay menu. + case 'o': + #call gdeactivate (gd, 0) + call rg_xoverlay (gd, xc, rg_xstati (xc, CREGION), imr, im1) + #call greactivate (gd, 0) + newplot = YES + + # Process colon commands. + case ':': + for (ip = 1; IS_WHITE(Memc[cmd+ip-1]); ip = ip + 1) + ; + switch (Memc[cmd+ip-1]) { + case 'x': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, + tfd, reglist, Memc[cmd], newdata, newcross, + newcenter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + cplottype = XC_PCOL + newplot = YES + } + case 'y': + if (Memc[cmd+ip] != EOS && Memc[cmd+ip] != ' ') { + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, + tfd, reglist, Memc[cmd], newdata, newcross, + newcenter) + } else { + ip = ip + 1 + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + cplottype = XC_PLINE + newplot = YES + } + default: + call rg_xcolon (gd, xc, imr, im1, im2, db, dformat, tfd, + reglist, Memc[cmd], newdata, newcross, newcenter) + } + + # Compute an image lag interactively. + case 't': + call gdeactivate (gd, 0) + call rg_itransform (xc, imr, im1, id) + newdata = YES; newcross = YES; newcenter = YES + call greactivate (gd, 0) + + # Write the parameters to the parameter file. + case 'w': + call rg_pxpars (xc) + + case 'f': + + if (rg_xstati (xc, NREGIONS) > 0) { + + if (newdata == YES) { + call rg_xcindefr (xc, rg_xstati(xc,CREGION)) + newdata = NO + } + + if (newcross == YES) { + call printf ( + "Recomputing X-correlation function ...\n") + if (rg_icross (xc, imr, im1, rg_xstati (xc, + CREGION)) != ERR) { + ncolr = (1 + rg_xstati (xc, XWINDOW)) / 2 + if (IM_NDIM(imr) == 1) + nliner = 1 + else + nliner = (1 + rg_xstati (xc, YWINDOW)) / 2 + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_fit (xc, rg_xstati (xc, CREGION), gd, + xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newcross = NO + newcenter = NO + newplot = NO + } else { + call printf ( + "Error computing X-correlation function for region %d\n") + call pargi (rg_xstati (xc, CREGION)) + } + } + + if (newcenter == YES) { + call rg_fit (xc, rg_xstati (xc, CREGION), gd, + xshift, yshift) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newcenter = NO + } + + } else + call printf ("The regions list is empty\n") + + + + # Do nothing gracefully. + default: + call printf ("Unknown or ambiguous keystroke command\n") + } + + # Replot the correlation function. + if (newplot == YES) { + if (newdata == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (newcross == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (newcenter == YES) { + call printf ( + "Warning: X-correlation function should be refit\n") + } else if (rg_xstatp (xc, XCOR) != NULL) { + call rg_xcplot (xc, gd, ncolr, nliner, cplottype) + call rg_xpwrec (xc, rg_xstati (xc, CREGION)) + newplot = NO + } else { + call printf ( + "Warning: X-correlation function is undefined\n") + } + } + } + + call sfree (sp) +end + + +# RG_XOVERLAY -- The image overlay plot menu. + +procedure rg_xoverlay (gd, xc, nreg, imr, im1) + +pointer gd #I graphics stream pointer +pointer xc #I pointer to the crosscor structure +int nreg #I the current region number +pointer imr #I pointer to the reference image +pointer im1 #I pointer to the input image + +int ip, wcs, key, ixlag, iylag, ixshift, iyshift +int nrimcols, nrimlines, nimcols, nimlines, ncolr, ncoli, nliner, nlinei +pointer sp, cmd +real wx, wy, rxlag, rylag, xshift, yshift +int clgcur(), ctoi(), rg_xstati() +pointer rg_xstatp() + +begin + if (gd == NULL) + return + + nrimcols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + nrimlines = 1 + else + nrimlines = IM_LEN(imr,2) + nimcols = IM_LEN(im1,1) + if (IM_NDIM(im1) == 1) + nimlines = 1 + else + nimlines = IM_LEN(im1,2) + if (rg_xstati (xc, NREFPTS) > 0) { + wx = (1. + nrimcols) / 2.0 + wy = (1. + nrimlines) / 2.0 + call rg_etransform (xc, wx, wy, rxlag, rylag) + ixlag = rxlag - wx + iylag = rylag - wy + } else { + ixlag = rg_xstati (xc, XLAG) + iylag = rg_xstati (xc, YLAG) + } + xshift = -Memr[rg_xstatp(xc,XSHIFTS)+nreg-1] + yshift = -Memr[rg_xstatp(xc,YSHIFTS)+nreg-1] + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + while (clgcur ("icommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + + switch (key) { + + # Print the help menu. + case '?': + call gdeactivate (gd, 0) + call pagefile (OHELPFILE, "") + call greactivate (gd, 0) + + # Quit. + case 'q': + break + + # Plot the same line of the reference and input image. + case 'l': + call rg_xpline (gd, imr, im1, nint (wy), 0, 0) + + # Plot the same column of the reference and input image + case 'c': + call rg_xpcol (gd, imr, im1, nint (wx), 0, 0) + + case 'y': + call rg_xpline (gd, imr, im1, nint (wy), ixlag, iylag) + + case 'x': + call rg_xpcol (gd, imr, im1, nint (wx), ixlag, iylag) + + case 'h': + call rg_xpline (gd, imr, im1, nint (wy), nint (xshift), + nint (yshift)) + + case 'v': + call rg_xpcol (gd, imr, im1, nint (wx), nint (xshift), + nint (yshift)) + + case ':': + ip = 1 + call rg_cokeys (Memc[cmd], ip, SZ_LINE, key) + switch (key) { + case 'l': + ixshift = 0 + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + if (ctoi (Memc[cmd], ip, nlinei) <= 0) + nlinei = nliner + iyshift = nlinei - nliner + call rg_xpline (gd, imr, im1, nliner, ixshift, iyshift) + + case 'c': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + if (ctoi (Memc[cmd], ip, ncoli) <= 0) + ncoli = ncolr + ncoli = max (1, min (ncoli, nimcols)) + ixshift = ncoli - ncolr + iyshift = 0 + call rg_xpcol (gd, imr, im1, ncolr, ixshift, iyshift) + + case 'y': + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + call rg_xpline (gd, imr, im1, nliner, ixlag, iylag) + + case 'x': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + call rg_xpcol (gd, imr, im1, ncolr, ixlag, iylag) + + case 'h': + if (ctoi (Memc[cmd], ip, nliner) <= 0) + nliner = (1 + nrimlines) / 2 + nliner = max (1, min (nliner, nrimlines)) + call rg_xpline (gd, imr, im1, nliner, nint (xshift), + nint (yshift)) + + case 'v': + if (ctoi (Memc[cmd], ip, ncolr) <= 0) + ncolr = (1 + nrimcols) / 2 + ncolr = max (1, min (ncolr, nrimcols)) + call rg_xpcol (gd, imr, im1, ncolr, nint (xshift), + nint (yshift)) + default: + call printf ("Ambiguous or unknown overlay menu command\n") + } + case 'g': + while (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], + SZ_LINE) != EOF) { + if (key == 'q') + break + } + default: + call printf ("Ambiguous or unknown overlay menu command\n") + } + + } + + call sfree (sp) +end + + +# RG_XCPLOT -- Draw the default plot of the cross-correlation function. + +procedure rg_xcplot (xc, gd, col, line, plottype) + +pointer xc #I pointer to cross-correlation structure +pointer gd #I pointer to the graphics stream +int col #I column of cross-correlation function to plot +int line #I line of cross-correlation function to plot +int plottype #I the default plot type + +int nreg, xwindow, ywindow +pointer sp, title, str, prc1, prc2, prl1, prl2 +int rg_xstati(), strlen() +pointer rg_xstatp() + +begin + if (gd == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the regions. + nreg = rg_xstati (xc, CREGION) + prc1 = rg_xstatp (xc, RC1) + prc2 = rg_xstatp (xc, RC2) + prl1 = rg_xstatp (xc, RL1) + prl2 = rg_xstatp (xc, RL2) + + # Initialize the window size. + xwindow = rg_xstati (xc, XWINDOW) + if ((Memi[prl2+nreg-1] - Memi[prl1+nreg-1] + 1) == 1) + ywindow = 1 + else + ywindow = rg_xstati (xc, YWINDOW) + + # Construct a title. + call sprintf (Memc[title], SZ_LINE, + "Reference: %s Image: %s Region: [%d:%d,%d:%d]") + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call pargi (Memi[prc1+nreg-1]) + call pargi (Memi[prc2+nreg-1]) + call pargi (Memi[prl1+nreg-1]) + call pargi (Memi[prl2+nreg-1]) + + # Draw the plot. + if (ywindow == 1) { + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: line %d") + call pargi (1) + call rg_xcpline (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, 1) + } else { + switch (plottype) { + case XC_PCONTOUR: + call rg_contour (gd, "X-Correlation Function", Memc[title], + Memr[rg_xstatp (xc, XCOR)], xwindow, ywindow) + case XC_PLINE: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: line %d") + call pargi (line) + call rg_xcpline (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, line) + case XC_PCOL: + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "\nX-Correlation Function: column %d") + call pargi (col) + call rg_xcpcol (gd, Memc[title], Memr[rg_xstatp(xc,XCOR)], + xwindow, ywindow, col) + default: + call rg_contour (gd, "X-Correlation Function", Memc[title], + Memr[rg_xstatp (xc, XCOR)], xwindow, ywindow) + } + } + + call sfree (sp) +end + + +# RG_COKEYS -- Fetch the first keystroke of a colon command. + +procedure rg_cokeys (cmd, ip, maxch, key) + +char cmd[ARB] #I the command string +int ip #I/O pointer into the command string +int maxch #I maximum number of characters +int key #O the keystroke + +begin + ip = 1 + while (IS_WHITE(cmd[ip]) && cmd[ip] != EOS && ip <= maxch) + ip = ip + 1 + + if (cmd[ip] == EOS && ip > maxch) + key = EOS + else { + key = cmd[ip] + ip = ip + 1 + } +end + + +define QUERY "Hit [return=continue, n=next image, q=quit, w=quit and update parameters]: " + +# RG_XGQVERIFY -- Print a message on the status line asking the user if they +# really want to quit, returning YES if they really want to quit, NO otherwise. + +int procedure rg_xgqverify (task, db, dformat, rg, ch) + +char task[ARB] #I the calling task name +pointer db #I pointer to the shifts database file +int dformat #I is the shifts file in database format +pointer rg #I pointer to the task structure +int ch #I the input keystroke command + +int wcs, stat +pointer sp, cmd +real wx, wy +bool streq() +int clgcur() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Print the status line query in reverse video and get the keystroke. + call printf (QUERY) + #call flush (STDOUT) + if (clgcur ("gcommands", wx, wy, wcs, ch, Memc[cmd], SZ_LINE) == EOF) + ; + + # Process the command. + if (ch == 'q') { + call rg_xwrec (db, dformat, rg) + stat = YES + } else if (ch == 'w') { + call rg_xwrec (db, dformat, rg) + if (streq ("xregister", task)) + call rg_pxpars (rg) + stat = YES + } else if (ch == 'n') { + call rg_xwrec (db, dformat, rg) + stat = YES + } else { + stat = NO + } + + call sfree (sp) + return (stat) +end + + +# RG_XGTVERIFY -- Verify whether or not the user truly wishes to quit the +# task. + +int procedure rg_xgtverify (ch) + +int ch #I the input keystroke command + +begin + if (ch == 'q') { + return (YES) + } else if (ch == 'w') { + return (YES) + } else if (ch == 'n') { + return (NO) + } else { + return (NO) + } +end diff --git a/pkg/images/immatch/src/xregister/rgximshift.x b/pkg/images/immatch/src/xregister/rgximshift.x new file mode 100644 index 00000000..08cb3f62 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgximshift.x @@ -0,0 +1,391 @@ +include +include +include + +define NYOUT 16 # number of lines output at once +define NMARGIN 3 # number of boundary pixels required +define NMARGIN_SPLINE3 16 # number of spline boundary pixels required + + +# RG_XSHIFTIM - Shift a 1 or 2D image by a fractional pixel amount +# x and y + +procedure rg_xshiftim (im1, im2, xshift, yshift, interpstr, boundary_type, + constant) + +pointer im1 #I pointer to input image +pointer im2 #I pointer to output image +real xshift #I shift in x direction +real yshift #I shift in y direction +char interpstr[ARB] #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I value of constant for boundary extension + +int interp_type +pointer sp, str +bool fp_equalr() +int strdic() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + interp_type = strdic (interpstr, Memc[str], SZ_FNAME, II_BFUNCTIONS) + + if (interp_type == II_NEAREST) + call rg_xishiftim (im1, im2, nint (xshift), nint (yshift), + interp_type, boundary_type, constant) + else if (fp_equalr (xshift, real (int (xshift))) && fp_equalr (yshift, + real (int (xshift)))) + call rg_xishiftim (im1, im2, int (xshift), int (yshift), + interp_type, boundary_type, constant) + else + call rg_xfshiftim (im1, im2, xshift, yshift, interpstr, + boundary_type, constant) + call sfree (sp) +end + + +# RG_XISHIFTIM -- Shift a 2-D image by integral pixels in x and y. + +procedure rg_xishiftim (im1, im2, nxshift, nyshift, interp_type, boundary_type, + constant) + +pointer im1 #I pointer to the input image +pointer im2 #I pointer to the output image +int nxshift, nyshift #I shift in x and y +int interp_type #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I constant for boundary extension + +int ixshift, iyshift +pointer buf1, buf2 +long v[IM_MAXDIM] +int ncols, nlines, nbpix +int i, x1col, x2col, yline + +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer imgs2s(), imgs2i(), imgs2l(), imgs2r(), imgs2d(), imgs2x() +errchk impnls, impnli, impnll, impnlr, impnld, impnlx +errchk imgs2s, imgs2i, imgs2l, imgs2r, imgs2d, imgs2x +string wrerr "ISHIFTXY: Error writing in image." + +begin + ixshift = nxshift + iyshift = nyshift + + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Cannot shift off image. + if (ixshift < -ncols || ixshift > ncols) + call error (3, "ISHIFTXY: X shift out of bounds.") + if (iyshift < -nlines || iyshift > nlines) + call error (4, "ISHIFTXY: Y shift out of bounds.") + + # Calculate the shift. + switch (boundary_type) { + case BT_CONSTANT,BT_REFLECT,BT_NEAREST: + ixshift = min (ncols, max (-ncols, ixshift)) + iyshift = min (nlines, max (-nlines, iyshift)) + case BT_WRAP: + ixshift = mod (ixshift, ncols) + iyshift = mod (iyshift, nlines) + } + + # Set the boundary extension values. + nbpix = max (abs (ixshift), abs (iyshift)) + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Get column boundaries in the input image. + x1col = max (-ncols + 1, - ixshift + 1) + x2col = min (2 * ncols, ncols - ixshift) + + call amovkl (long (1), v, IM_MAXDIM) + + # Shift the image using the appropriate data type operators. + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + do i = 1, nlines { + if (impnls (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2s (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovs (Mems[buf1], Mems[buf2], ncols) + } + case TY_INT: + do i = 1, nlines { + if (impnli (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2i (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovi (Memi[buf1], Memi[buf2], ncols) + } + case TY_USHORT, TY_LONG: + do i = 1, nlines { + if (impnll (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2l (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovl (Meml[buf1], Meml[buf2], ncols) + } + case TY_REAL: + do i = 1, nlines { + if (impnlr (im2, buf2, v) == EOF) + call error (5, wrerr) + yline = i - iyshift + buf1 = imgs2r (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (5, wrerr) + call amovr (Memr[buf1], Memr[buf2], ncols) + } + case TY_DOUBLE: + do i = 1, nlines { + if (impnld (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2d (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovd (Memd[buf1], Memd[buf2], ncols) + } + case TY_COMPLEX: + do i = 1, nlines { + if (impnlx (im2, buf2, v) == EOF) + call error (0, wrerr) + yline = i - iyshift + buf1 = imgs2x (im1, x1col, x2col, yline, yline) + if (buf1 == EOF) + call error (0, wrerr) + call amovx (Memx[buf1], Memx[buf2], ncols) + } + default: + call error (6, "ISHIFTXY: Unknown IRAF type.") + } +end + + + +# RG_XFSHIFTIM -- Shift a 1 or 2D image by a fractional pixel amount +# in x and y. + +procedure rg_xfshiftim (im1, im2, xshift, yshift, interpstr, boundary_type, + constant) + +pointer im1 #I pointer to input image +pointer im2 #I pointer to output image +real xshift #I shift in x direction +real yshift #I shift in y direction +char interpstr[ARB] #I type of interpolant +int boundary_type #I type of boundary extension +real constant #I value of constant for boundary extension + +int i, interp_type, nsinc, nincr +int ncols, nlines, nbpix, fstline, lstline, nxymargin +int cin1, cin2, nxin, lin1, lin2, nyin +int lout1, lout2, nyout +real xshft, yshft, deltax, deltay, dx, dy, cx, ly +pointer sp, x, y, msi, sinbuf, soutbuf +bool fp_equalr() +int msigeti() +pointer imps2r() + +errchk imgs2r, imps2r +errchk msiinit, msifree, msifit, msigrid +errchk smark, salloc, sfree + +begin + ncols = IM_LEN(im1,1) + nlines = IM_LEN(im1,2) + + # Check for out of bounds shift. + if (xshift < -ncols || xshift > ncols) + call error (0, "XC_SHIFTIM: X shift out of bounds.") + if (yshift < -nlines || yshift > nlines) + call error (0, "XC_SHIFTIM: Y shift out of bounds.") + + # Get the real shift. + if (boundary_type == BT_WRAP) { + xshft = mod (xshift, real (ncols)) + yshft = mod (yshift, real (nlines)) + } else { + xshft = xshift + yshft = yshift + } + + # Allocate temporary space. + call smark (sp) + call salloc (x, 2 * ncols, TY_REAL) + call salloc (y, 2 * nlines, TY_REAL) + sinbuf = NULL + + # Define the x and y interpolation coordinates. + dx = abs (xshft - int (xshft)) + if (fp_equalr (dx, 0.0)) + deltax = 0.0 + else if (xshft > 0.) + deltax = 1. - dx + else + deltax = dx + dy = abs (yshft - int (yshft)) + if (fp_equalr (dy, 0.0)) + deltay = 0.0 + else if (yshft > 0.) + deltay = 1. - dy + else + deltay = dy + + # Initialize the 2-D interpolation routines. + call msitype (interpstr, interp_type, nsinc, nincr, cx) + if (interp_type == II_BILSINC || interp_type == II_BISINC) + call msisinit (msi, interp_type, nsinc, 1, 1, + deltax - nint (deltax), deltay - nint (deltay), 0.0) + else + call msisinit (msi, interp_type, nsinc, 1, 1, cx, cx, 0.0) + + # Set boundary extension parameters. + if (interp_type == II_BISPLINE3) + nxymargin = NMARGIN_SPLINE3 + else if (interp_type == II_BISINC || interp_type == II_BILSINC) + nxymargin = msigeti (msi, II_MSINSINC) + else + nxymargin = NMARGIN + nbpix = max (int (abs(xshft)+1.0), int (abs(yshft)+1.0)) + nxymargin + call imseti (im1, IM_NBNDRYPIX, nbpix) + call imseti (im1, IM_TYBNDRY, boundary_type) + if (boundary_type == BT_CONSTANT) + call imsetr (im1, IM_BNDRYPIXVAL, constant) + + # Define the x interpolation coordinates. + deltax = deltax + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, ncols { + Memr[x+2*i-2] = i + deltax - 0.5 + Memr[x+2*i-1] = i + deltax + 0.5 + } + } else { + do i = 1, ncols + Memr[x+i-1] = i + deltax + } + + # Define the y interpolation coordinates. + deltay = deltay + nxymargin + if (interp_type == II_BIDRIZZLE) { + do i = 1, NYOUT { + Memr[y+2*i-2] = i + deltay - 0.5 + Memr[y+2*i-1] = i + deltay + 0.5 + } + } else { + do i = 1, NYOUT + Memr[y+i-1] = i + deltay + } + + # Define column range in the input image. + cx = 1. - nxymargin - xshft + if ((cx <= 0.) && (! fp_equalr (dx, 0.0))) + cin1 = int (cx) - 1 + else + cin1 = int (cx) + cin2 = ncols - xshft + nxymargin + 1 + nxin = cin2 - cin1 + 1 + + # Loop over output sections. + for (lout1 = 1; lout1 <= nlines; lout1 = lout1 + NYOUT) { + + # Define range of output lines. + lout2 = min (lout1 + NYOUT - 1, nlines) + nyout = lout2 - lout1 + 1 + + # Define correspoding range of input lines. + ly = lout1 - nxymargin - yshft + if ((ly <= 0) && (! fp_equalr (dy, 0.0))) + lin1 = int (ly) - 1 + else + lin1 = int (ly) + lin2 = lout2 - yshft + nxymargin + 1 + nyin = lin2 - lin1 + 1 + + # Get appropriate input image section and compute the coefficients. + if ((sinbuf == NULL) || (lin1 < fstline) || (lin2 > lstline)) { + fstline = lin1 + lstline = lin2 + call rg_buf (im1, cin1, cin2, lin1, lin2, sinbuf) + call msifit (msi, Memr[sinbuf], nxin, nyin, nxin) + } + + # Output the image section. + soutbuf = imps2r (im2, 1, ncols, lout1, lout2) + if (soutbuf == EOF) + call error (0, "GSHIFTXY: Error writing output image.") + + # Evaluate the interpolant. + call msigrid (msi, Memr[x], Memr[y], Memr[soutbuf], ncols, nyout, + ncols) + } + + call msifree (msi) + call sfree (sp) +end + + +# RG_BUF -- Procedure to provide a buffer of image lines with minimum reads + +procedure rg_buf (im, col1, col2, line1, line2, buf) + +pointer im #I pointer to input image +int col1, col2 #I column range of input buffer +int line1, line2 #I line range of input buffer +pointer buf #I buffer + +int i, ncols, nlines, nclast, llast1, llast2, nllast +pointer buf1, buf2 + +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end diff --git a/pkg/images/immatch/src/xregister/rgxplot.x b/pkg/images/immatch/src/xregister/rgxplot.x new file mode 100644 index 00000000..8b347ab5 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxplot.x @@ -0,0 +1,317 @@ +include +include + +# RG_XPLINE -- Plot a line of reference and input image. + +procedure rg_xpline (gd, imr, im, nliner, xshift, yshift) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im #I pointer to the image +int nliner #I the reference line +int xshift #I x shift +int yshift #I y shift + +int i, rncols, rnlines, incols, inlines +pointer sp, title, xr, xi, ptrr, ptri +real ymin, ymax, tymin, tymax +int strlen() +pointer imgl1r(), imgl2r() + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + rncols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + rnlines = 1 + else + rnlines = IM_LEN(imr,2) + incols = IM_LEN(im,1) + if (IM_NDIM(im) == 1) + inlines = 1 + else + inlines = IM_LEN(im,2) + if ((nliner < 1) || (nliner > rnlines)) + return + if (((nliner + yshift) < 1) || ((nliner + yshift) > inlines)) + return + + # Allocate working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (xr, rncols, TY_REAL) + call salloc (xi, rncols, TY_REAL) + + # Initialize the x data data. + do i = 1, rncols { + Memr[xr+i-1] = i + Memr[xi+i-1] = i - xshift + } + + # Initalize the y data. + if (IM_NDIM(imr) == 1) + ptrr = imgl1r (imr) + else + ptrr = imgl2r (imr, nliner) + if (IM_NDIM(im) == 1) + ptri = imgl1r (im) + else + ptri = imgl2r (im, nliner + yshift) + call alimr (Memr[ptrr], rncols, ymin, ymax) + call alimr (Memr[ptri], incols, tymin, tymax) + ymin = min (ymin, tymin) + ymax = max (ymax, tymax) + + # Construct the title. + call sprintf (Memc[title], SZ_LINE, + "Refimage: %s Image: %s\n") + call pargstr (IM_HDRFILE(imr)) + call pargstr (IM_HDRFILE(im)) + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "Refline (solid): %d Inline (dashed): %d Xlag: %d Ylag: %d") + call pargi (nliner) + call pargi (nliner + yshift) + call pargi (xshift) + call pargi (yshift) + + # Set up the axes labels and window. + call gclear (gd) + call gswind (gd, 1.0, real(rncols), ymin, ymax) + call glabax (gd, Memc[title], "Column Number", "Counts") + + # Plot the two lines. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[xr], Memr[ptrr], rncols) + call gseti (gd, G_PLTYPE, GL_DASHED) + call gpline (gd, Memr[xi], Memr[ptri], incols) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XPCOL -- Plot a column in the reference and input image. + +procedure rg_xpcol (gd, imr, im, ncolr, xshift, yshift) + +pointer gd #I pointer to the graphics stream +pointer imr #I pointer to the reference image +pointer im #I pointer to the image +int ncolr #I the line number +int xshift #I xshift to be applied +int yshift #I yshift to be applied + +int i, rncols, rnlines, incols, inlines +pointer sp, title, xr, xi, ptrr, ptri +real ymin, ymax, tymin, tymax +int strlen() +pointer imgs1r(), imgs2r() + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + rncols = IM_LEN(imr,1) + if (IM_NDIM(imr) == 1) + rnlines = 1 + else + rnlines = IM_LEN(imr,2) + incols = IM_LEN(im,1) + if (IM_NDIM(im) == 1) + inlines = 1 + else + inlines = IM_LEN(im,2) + if ((ncolr < 1) || (ncolr > rncols)) + return + if (((ncolr - xshift) < 1) || ((ncolr - xshift) > incols)) + return + + # Allocate valid working space. + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (xr, rnlines, TY_REAL) + call salloc (xi, inlines, TY_REAL) + + # Initialize the data. + do i = 1, rnlines { + Memr[xr+i-1] = i + Memr[xi+i-1] = i - yshift + } + if (IM_NDIM(imr) == 1) + ptrr = imgs1r (imr, ncolr, ncolr) + else + ptrr = imgs2r (imr, ncolr, ncolr, 1, rnlines) + if (IM_NDIM(im) == 1) + ptri = imgs1r (im, ncolr + xshift, ncolr + xshift) + else + ptri = imgs2r (im, ncolr + xshift, ncolr + xshift, 1, inlines) + call alimr (Memr[ptrr], rnlines, ymin, ymax) + call alimr (Memr[ptri], inlines, tymin, tymax) + ymin = min (ymin, tymin) + ymax = max (ymax, tymax) + + # Construct the title. + call sprintf (Memc[title], SZ_LINE, "Refimage: %s Image: %s\n") + call pargstr (IM_HDRFILE(imr)) + call pargstr (IM_HDRFILE(im)) + call sprintf (Memc[title+strlen(Memc[title])], SZ_LINE, + "Refcol (solid): %d Imcol (dashed): %d Xlag: %d Ylag: %d") + call pargi (ncolr) + call pargi (ncolr + xshift) + call pargi (xshift) + call pargi (yshift) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (rnlines), ymin, ymax) + call glabax (gd, Memc[title], "Line Number", "Counts") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[xr], Memr[ptrr], rnlines) + call gseti (gd, G_PLTYPE, GL_DASHED) + call gpline (gd, Memr[xi], Memr[ptri], rnlines) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XCPLINE -- Plot a line of the 2D correlation function. + +procedure rg_xcpline (gd, title, data, nx, ny, nline) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title for the plot +real data[nx,ARB] #I the input data array +int nx, ny #I dimensions of the input data array +int nline #I the line number + +int i +pointer sp, str, x +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid line number. + if (nline < 1 || nline > ny) + return + + # Allocate some working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (x, nx, TY_REAL) + + # Initialize the data. + do i = 1, nx + Memr[x+i-1] = i + call alimr (data[1,nline], nx, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (nx), ymin, ymax) + call glabax (gd, title, "X Lag", "X-Correlation Function") + + # Plot the line profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], data[1,nline], nx) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XCPCOL -- Plot a column of the cross-correlation function. + +procedure rg_xcpcol (gd, title, data, nx, ny, ncol) + +pointer gd #I pointer to the graphics stream +char title[ARB] #I title of the column plot +real data[nx,ARB] #I the input data array +int nx, ny #I the dimensions of the input data array +int ncol #I line number + +int i +pointer sp, x, y +real ymin, ymax + +begin + # Return if no graphics stream. + if (gd == NULL) + return + + # Check for valid column number. + if (ncol < 1 || ncol > nx) + return + + # Initialize. + call smark (sp) + call salloc (x, ny, TY_REAL) + call salloc (y, ny, TY_REAL) + + # Get the data to be plotted. + do i = 1, ny { + Memr[x+i-1] = i + Memr[y+i-1] = data[ncol,i] + } + call alimr (Memr[y], ny, ymin, ymax) + + # Set up the labels and the axes. + call gclear (gd) + call gswind (gd, 1.0, real (ny), ymin, ymax) + call glabax (gd, title, "Y Lag", "X-Correlation Function") + + # Plot the profile. + call gseti (gd, G_PLTYPE, GL_SOLID) + call gpline (gd, Memr[x], Memr[y], ny) + call gflush (gd) + + call sfree (sp) +end + + +# RG_XMKPEAK -- Procedure to mark the peak from a correlation function +# contour plot. + +procedure rg_xmkpeak (gd, xwindow, ywindow, xshift, yshift) + +pointer gd #I pointer to the graphics stream +int xwindow #I x dimension of correlation function +int ywindow #I y dimension of correlation function +real xshift #O x shift +real yshift #O y shift + +int wcs, key +pointer sp, cmd +real wx, wy +int clgcur() + +begin + if (gd == NULL) + return + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + call printf ("Mark peak of the cross correlation function\n") + if (clgcur ("gcommands", wx, wy, wcs, key, Memc[cmd], SZ_LINE) == EOF) + ; + if (wx < 1.0 || wx > real (xwindow) || wy < 1.0 || wy > + real (ywindow)) { + xshift = 0.0 + yshift = 0.0 + } else { + xshift = wx - (1 + xwindow) / 2 + yshift = wy - (1 + ywindow) / 2 + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxppars.x b/pkg/images/immatch/src/xregister/rgxppars.x new file mode 100644 index 00000000..2dc6aafd --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxppars.x @@ -0,0 +1,49 @@ +include "xregister.h" + +# RG_PXPARS -- Update the cross-correlation algorithm parameters. + +procedure rg_pxpars (xc) + +pointer xc #I pointer to the cross-correlation structure + +pointer sp, str +int rg_xstati() +real rg_xstatr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Define the regions. + call rg_xstats (xc, REGIONS, Memc[str], SZ_LINE) + call clpstr ("regions", Memc[str]) + call clputi ("xlag", rg_xstati (xc, XLAG)) + call clputi ("ylag", rg_xstati (xc, YLAG)) + call clputi ("dxlag", rg_xstati (xc, DXLAG)) + call clputi ("dylag", rg_xstati (xc, DYLAG)) + + # Store the background fitting parameters. + call rg_xstats (xc, BSTRING, Memc[str], SZ_LINE) + call clpstr ("background", Memc[str]) + call clputi ("border", rg_xstati (xc, BORDER)) + call clputr ("loreject", rg_xstatr (xc, LOREJECT)) + call clputr ("hireject", rg_xstatr (xc, HIREJECT)) + call clputr ("apodize", rg_xstatr (xc, APODIZE)) + call rg_xstats (xc, FSTRING, Memc[str], SZ_LINE) + call clpstr ("filter", Memc[str]) + + # Store the cross-correlation parameters. + call rg_xstats (xc, CSTRING, Memc[str], SZ_LINE) + call clpstr ("correlation", Memc[str]) + call clputi ("xwindow", rg_xstati (xc, XWINDOW)) + call clputi ("ywindow", rg_xstati (xc, YWINDOW)) + + # Store the peak centering parameters. + call rg_xstats (xc, PSTRING, Memc[str], SZ_LINE) + call clpstr ("function", Memc[str]) + call clputi ("xcbox", rg_xstati (xc, XCBOX)) + call clputi ("ycbox", rg_xstati (xc, YCBOX)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxregions.x b/pkg/images/immatch/src/xregister/rgxregions.x new file mode 100644 index 00000000..ed682f61 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxregions.x @@ -0,0 +1,459 @@ +include +include +include +include "xregister.h" + +# RG_XREGIONS -- Decode the image sections into regions. If the sections string +# is NULL then the regions list is initially empty and depending on the mode +# of the task, XREGISTER will or will not complain.Otherwise the image +# sections specified in the sections string or file are decoded into a +# regions list. + +int procedure rg_xregions (list, im, xc, rp) + +int list #I pointer to the regions list +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region + +int fd, nregions +pointer sp, fname, regions +int rg_xgrid(), rg_xgregions(), rg_xrregions(), rg_xstati(), fntgfnb() +int open() +errchk fntgfnb(), open(), close() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (regions, SZ_LINE, TY_CHAR) + + call rg_xstats (xc, REGIONS, Memc[regions], SZ_LINE) + if (rp < 1 || rp > MAX_NREGIONS || Memc[regions] == EOS) { + nregions = 0 + } else if (rg_xgrid (im, xc, rp, MAX_NREGIONS) > 0) { + nregions = rg_xstati (xc, NREGIONS) + } else if (rg_xgregions (im, xc, rp, MAX_NREGIONS) > 0) { + nregions = rg_xstati (xc, NREGIONS) + } else if (list != NULL) { + iferr { + if (fntgfnb (list, Memc[fname], SZ_FNAME) != EOF) { + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + nregions= rg_xrregions (fd, im, xc, rp, MAX_NREGIONS) + call close (fd) + } + } then + nregions = 0 + } else + nregions = 0 + + call sfree (sp) + + return (nregions) +end + + +# RG_XMKREGIONS -- Create a list of regions by marking image sections +# on the image display. + +int procedure rg_xmkregions (im, xc, rp, max_nregions, regions, maxch) + +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions +char regions[ARB] #O the output regions string +int maxch #I maximum size of the output regions string + +int op, nregions, wcs, key +pointer sp, region, section, cmd +real xll, yll, xur, yur +int rg_xstati(), clgcur(), gstrcpy() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + nregions = min (rp-1, rg_xstati (xc, NREGIONS)) + op = 1 + + # Mark the sections on the display. + while (nregions < max_nregions) { + + call printf ("Mark lower left corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xll, yll, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + call printf ("Mark upper right corner of region %d [q to quit].\n") + call pargi (nregions + 1) + if (clgcur ("icommands", xur, yur, wcs, key, Memc[cmd], + SZ_LINE) == EOF) + break + if (key == 'q') + break + + if (xll < 1.0 || xur > IM_LEN(im,1) || yll < 1.0 || yur > + IM_LEN(im,2)) + break + + Memi[rg_xstatp(xc,RC1)+nregions] = nint (xll) + Memi[rg_xstatp(xc,RC2)+nregions] = nint (xur) + Memi[rg_xstatp(xc,RL1)+nregions] = nint (yll) + Memi[rg_xstatp(xc,RL2)+nregions] = nint (yur) + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + + # Write the first 9 regions into the regions string. + call sprintf (Memc[cmd], SZ_LINE, "[%d:%d,%d:%d] ") + call pargi (nint (xll)) + call pargi (nint (xur)) + call pargi (nint (yll)) + call pargi (nint (yur)) + op = op + gstrcpy (Memc[cmd], regions[op], maxch - op + 1) + } + call printf ("\n") + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGRID - Decode the regions from a grid specification. + +int procedure rg_xgrid (im, xc, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int i, istart, iend, j, jstart, jend, ncols, nlines, nxsample, nysample +int nxcols, nylines, nregions +pointer sp, region, section +int rg_xstati(), nscan(), strcmp() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + call rg_xstats (xc, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the grid specification. + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + call gargi (nxsample) + call gargi (nysample) + if ((nscan() != 3) || (strcmp (Memc[section], "grid") != 0)) { + call sfree (sp) + return (nregions) + } + + # Decode the regions. + if ((nxsample * nysample) > max_nregions) { + nxsample = nint (sqrt (real (max_nregions) * real (ncols) / + real (nlines))) + nysample = real (max_nregions) / real (nxsample) + } + nxcols = ncols / nxsample + nylines = nlines / nysample + jstart = 1 + (nlines - nysample * nylines) / 2 + jend = jstart + (nysample - 1) * nylines + do j = jstart, jend, nylines { + istart = 1 + (ncols - nxsample * nxcols) / 2 + iend = istart + (nxsample - 1) * nxcols + do i = istart, iend, nxcols { + Memi[rg_xstatp(xc,RC1)+nregions] = i + Memi[rg_xstatp(xc,RC2)+nregions] = i + nxcols - 1 + Memi[rg_xstatp(xc,RL1)+nregions] = j + Memi[rg_xstatp(xc,RL2)+nregions] = j + nylines - 1 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + } + + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + call sfree (sp) + + return (nregions) +end + + +# RG_XRREGIONS -- Read and decode the regions from a file. + +int procedure rg_xrregions (fd, im, xc, rp, max_nregions) + +int fd #I regions file descriptor +pointer im #I pointer to the reference image +pointer xc #I pointer to the cross-correlation structure +int rp #I index of the current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, y1, x2, y2, step +pointer sp, line, section +int rg_xstati(), getline(), rg_xgsections() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information, + call rg_xrealloc (xc, max_nregions) + + # Initialize. + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the regions string. + while ((getline (fd, Memc[line]) != EOF) && nregions < max_nregions) { + call sscan (Memc[line]) + call gargwrd (Memc[section], SZ_LINE) + while ((Memc[section] != EOS) && (nregions < max_nregions)) { + if (rg_xgsections (Memc[section], x1, x2, step, y1, y2, step, + ncols, nlines) == OK) { + Memi[rg_xstatp(xc,RC1)+nregions] = x1 + Memi[rg_xstatp(xc,RC2)+nregions] = x2 + Memi[rg_xstatp(xc,RL1)+nregions] = y1 + Memi[rg_xstatp(xc,RL2)+nregions] = y2 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + } + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGREGIONS -- Decode a list of regions from a string containing +# a list of sections. + +int procedure rg_xgregions (im, xc, rp, max_nregions) + +pointer im #I pointer to the reference image +pointer xc #I pointer to cross-correlation structure +int rp #I the index of the current region +int max_nregions #I the maximum number of regions + +int ncols, nlines, nregions, x1, x2, y1, y2, step +pointer sp, section, region +int rg_xstati(), rg_xgsections() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (region, SZ_LINE, TY_CHAR) + call salloc (section, SZ_LINE, TY_CHAR) + + # Allocate the arrays to hold the regions information. + call rg_xrealloc (xc, max_nregions) + + # Initialize. + call rg_xstats (xc, REGIONS, Memc[region], SZ_LINE) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + nregions = min (rp - 1, rg_xstati (xc, NREGIONS)) + + # Decode the sections + call sscan (Memc[region]) + call gargwrd (Memc[section], SZ_LINE) + while ((Memc[section] != EOS) && (nregions < max_nregions)) { + if (rg_xgsections (Memc[section], x1, x2, step, y1, y2, step, + ncols, nlines) == OK) { + Memi[rg_xstatp(xc,RC1)+nregions] = x1 + Memi[rg_xstatp(xc,RC2)+nregions] = x2 + Memi[rg_xstatp(xc,RL1)+nregions] = y1 + Memi[rg_xstatp(xc,RL2)+nregions] = y2 + Memr[rg_xstatp(xc,RZERO)+nregions] = INDEFR + Memr[rg_xstatp(xc,RXSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,RYSLOPE)+nregions] = INDEFR + Memr[rg_xstatp(xc,XSHIFTS)+nregions] = INDEFR + Memr[rg_xstatp(xc,YSHIFTS)+nregions] = INDEFR + nregions = nregions + 1 + } + call gargwrd (Memc[section], SZ_LINE) + } + + + # Reallocate the correct amount of space. + call rg_xseti (xc, NREGIONS, nregions) + if (nregions > 0) + call rg_xrealloc (xc, nregions) + else + call rg_xrfree (xc) + + call sfree (sp) + + return (nregions) +end + + +# RG_XGSECTIONS -- Decode an image section into column and line limits +# and a step size. Sections which describe the whole image are decoded into +# a block ncols * nlines long. + +int procedure rg_xgsections (section, x1, x2, xstep, y1, y2, ystep, ncols, + nlines) + +char section[ARB] #I the input section string +int x1, x2 #O the output column section limits +int xstep #O the output column step size +int y1, y2 #O the output line section limits +int ystep #O the output line step size +int ncols, nlines #I the maximum number of lines and columns + +int ip +int rg_xgdim() + +begin + ip = 1 + if (rg_xgdim (section, ip, x1, x2, xstep, ncols) == ERR) + return (ERR) + if (rg_xgdim (section, ip, y1, y2, ystep, nlines) == ERR) + return (ERR) + + return (OK) +end + + +# RG_XGDIM -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +int procedure rg_xgdim (section, ip, x1, x2, step, limit) + +char section[ARB] #I the input image section +int ip #I/O pointer to the position in section string +int x1 #O first limit of dimension +int x2 #O second limit of dimension +int step #O step size of dimension +int limit #I maximum size of dimension + +int temp +int ctoi() + +begin + x1 = 1 + x2 = limit + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] =='[') + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get X1, X2. + if (ctoi (section, ip, temp) > 0) { # [x1 + x1 = max (1, min (temp, limit)) + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, temp) == 0) # [x1:x2 + return (ERR) + x2 = max (1, min (temp, limit)) + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = limit + x2 = 1 + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, step) == 0) + return (ERR) + else if (step == 0) + return (ERR) + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return (OK) + } else if (section[ip] == ']') + return (OK) + else + return (ERR) +end diff --git a/pkg/images/immatch/src/xregister/rgxshow.x b/pkg/images/immatch/src/xregister/rgxshow.x new file mode 100644 index 00000000..3a746d9c --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxshow.x @@ -0,0 +1,172 @@ +include "xregister.h" + +# RG_XSHOW -- Show the XREGISTER parameters. + +procedure rg_xshow (xc) + +pointer xc #I pointer to the main xregister structure + +begin + call rg_xnshow (xc) + call printf ("\n") + call rg_xbshow (xc) + call printf ("\n") + call rg_xxshow (xc) + call printf ("\n") + call rg_xpshow (xc) +end + + +# RG_XNSHOW -- Show the input/output data XREGISTER parameters. + +procedure rg_xnshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Set the object characteristics. + call printf ("\nInput/output data\n") + call rg_xstats (xc, IMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_IMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFIMAGE) + call pargstr (Memc[str]) + call rg_xstats (xc, REGIONS, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REGIONS) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XLAG) + call pargi (rg_xstati (xc, XLAG)) + call pargstr (KY_YLAG) + call pargi (rg_xstati (xc, YLAG)) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_DXLAG) + call pargi (rg_xstati (xc, DXLAG)) + call pargstr (KY_DYLAG) + call pargi (rg_xstati (xc, DYLAG)) + call rg_xstats (xc, DATABASE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_DATABASE) + call pargstr (Memc[str]) + call rg_xstats (xc, RECORD, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_RECORD) + call pargstr (Memc[str]) + call rg_xstats (xc, REFFILE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_REFFILE) + call pargstr (Memc[str]) + call rg_xstats (xc, OUTIMAGE, Memc[str], SZ_FNAME) + call printf (" %s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + + call sfree (sp) +end + + +# RG_XBSHOW -- Show the background fitting parameters. + +procedure rg_xbshow (xc) + +pointer xc #I pointer to the main xregister structure + +int back +pointer sp, str +int rg_xstati() +real rg_xstatr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + back = rg_xstati (xc, BACKGRD) + call printf ("Background fitting parameters:\n") + call rg_xstats (xc, BSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_BACKGROUND) + call pargstr (Memc[str]) + call printf (" %s = %d\n") + call pargstr (KY_BORDER) + call pargi (rg_xstati (xc, BORDER)) + call printf (" %s = %g %s = %g\n") + call pargstr (KY_LOREJECT) + call pargr (rg_xstatr (xc, LOREJECT)) + call pargstr (KY_HIREJECT) + call pargr (rg_xstatr (xc, HIREJECT)) + call printf (" %s = %g\n") + call pargstr (KY_APODIZE) + call pargr (rg_xstatr (xc, APODIZE)) + call rg_xstats (xc, FSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_FILTER) + call pargstr (Memc[str]) + + call sfree (sp) +end + + +# RG_XXSHOW -- Show the cross-correlation function parameters. + +procedure rg_xxshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call printf ("Cross correlation function:\n") + call rg_xstats (xc, CSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_CORRELATION) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XWINDOW) + call pargi (rg_xstati (xc, XWINDOW)) + call pargstr (KY_YWINDOW) + call pargi (rg_xstati (xc, YWINDOW)) + + call sfree (sp) +end + + +# RG_XPSHOW -- Show the peak centering parameters. + +procedure rg_xpshow (xc) + +pointer xc #I pointer to the main xregister structure + +pointer sp, str +int rg_xstati() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call printf ("Peak centering parameters:\n") + call rg_xstats (xc, PSTRING, Memc[str], SZ_LINE) + call printf (" %s: %s\n") + call pargstr (KY_PEAKCENTER) + call pargstr (Memc[str]) + call printf (" %s = %d %s = %d\n") + call pargstr (KY_XCBOX) + call pargi (rg_xstati (xc, XCBOX)) + call pargstr (KY_YCBOX) + call pargi (rg_xstati (xc, YCBOX)) + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxtools.x b/pkg/images/immatch/src/xregister/rgxtools.x new file mode 100644 index 00000000..e1fb921e --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxtools.x @@ -0,0 +1,685 @@ +include "xregister.h" + +# RG_XINIT -- Initialize the cross-correlation code fitting structure. + +procedure rg_xinit (xc, cfunc) + +pointer xc #O pointer to the cross-correlation structure +int cfunc #I the input cross-correlation function + +begin + call malloc (xc, LEN_XCSTRUCT, TY_STRUCT) + + # Initialize the regions pointers. + XC_RC1(xc) = NULL + XC_RC2(xc) = NULL + XC_RL1(xc) = NULL + XC_RL2(xc) = NULL + XC_RZERO(xc) = NULL + XC_RXSLOPE(xc) = NULL + XC_RYSLOPE(xc) = NULL + XC_XSHIFTS(xc) = NULL + XC_YSHIFTS(xc) = NULL + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 + XC_NREGIONS(xc) = 0 + XC_CREGION(xc) = 1 + + # Set up transformation parameters. + XC_NREFPTS(xc) = 0 + call malloc (XC_XREF(xc), MAX_NREF, TY_REAL) + call malloc (XC_YREF(xc), MAX_NREF, TY_REAL) + call malloc (XC_TRANSFORM(xc), MAX_NTRANSFORM, TY_REAL) + + # Initialize the region offsets + XC_IXLAG(xc) = DEF_IXLAG + XC_IYLAG(xc) = DEF_IYLAG + XC_XLAG(xc) = DEF_IXLAG + XC_YLAG(xc) = DEF_IYLAG + XC_DXLAG(xc) = DEF_DXLAG + XC_DYLAG(xc) = DEF_DYLAG + + # Define the background fitting parameters. + XC_BACKGRD(xc) = XC_BNONE + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + XC_BVALUER(xc) = 0.0 + XC_BVALUE(xc) = 0.0 + XC_BORDER(xc) = DEF_BORDER + XC_LOREJECT(xc) = DEF_LOREJECT + XC_HIREJECT(xc) = DEF_HIREJECT + XC_APODIZE(xc) = 0.0 + XC_FILTER(xc) = XC_FNONE + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + + # Get the correlation parameters. + XC_CFUNC(xc) = cfunc + switch (cfunc) { + case XC_DISCRETE: + call strcpy ("discrete", XC_CSTRING(xc), SZ_FNAME) + case XC_FOURIER: + call strcpy ("fourier", XC_CSTRING(xc), SZ_FNAME) + case XC_FILE: + call strcpy ("file", XC_CSTRING(xc), SZ_FNAME) + case XC_DIFFERENCE: + call strcpy ("difference", XC_CSTRING(xc), SZ_FNAME) + default: + call strcpy ("unknown", XC_CSTRING(xc), SZ_FNAME) + } + XC_XWINDOW(xc) = DEF_XWINDOW + XC_YWINDOW(xc) = DEF_YWINDOW + XC_XCOR(xc) = NULL + + # Define the peak fitting function. + XC_PFUNC(xc) = DEF_PFUNC + call sprintf (XC_PSTRING(xc), SZ_FNAME, "%s") + call pargstr ("centroid") + XC_XCBOX(xc) = DEF_XCBOX + XC_YCBOX(xc) = DEF_YCBOX + + # Initialize the strings. + XC_IMAGE(xc) = EOS + XC_REFIMAGE(xc) = EOS + XC_REGIONS(xc) = EOS + XC_DATABASE(xc) = EOS + XC_OUTIMAGE(xc) = EOS + XC_REFFILE(xc) = EOS + XC_RECORD(xc) = EOS + + # Initialize the buffers. + call rg_xrinit (xc) + +end + + +# RG_XRINIT -- Initialize the regions definition portion of the +# cross correlation code fitting structure. + +procedure rg_xrinit (xc) + +pointer xc #I pointer to crosscor structure + +begin + call rg_xrfree (xc) + + XC_NREGIONS(xc) = 0 + XC_CREGION(xc) = 1 + + call malloc (XC_RC1(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RC2(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RL1(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RL2(xc), MAX_NREGIONS, TY_INT) + call malloc (XC_RZERO(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_RXSLOPE(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_RYSLOPE(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_XSHIFTS(xc), MAX_NREGIONS, TY_REAL) + call malloc (XC_YSHIFTS(xc), MAX_NREGIONS, TY_REAL) + + call amovki (INDEFI, Memi[XC_RC1(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RC2(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RL1(xc)], MAX_NREGIONS) + call amovki (INDEFI, Memi[XC_RL2(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RZERO(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)], MAX_NREGIONS) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)], MAX_NREGIONS) + + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XCINDEFR -- Re-initialize the background and answers regions portion of +# the cross-correlation fitting structure + +procedure rg_xcindefr (xc, creg) + +pointer xc #I pointer to the cross-correlation structure +int creg #I the current region + +int nregions +int rg_xstati() + +begin + nregions = rg_xstati (xc, NREGIONS) + if (creg < 1 || creg > nregions) + return + + if (nregions > 0) { + Memr[XC_RZERO(xc)+creg-1] = INDEFR + Memr[XC_RXSLOPE(xc)+creg-1] = INDEFR + Memr[XC_RYSLOPE(xc)+creg-1] = INDEFR + Memr[XC_XSHIFTS(xc)+creg-1] = INDEFR + Memr[XC_YSHIFTS(xc)+creg-1] = INDEFR + } + + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XINDEFR -- Re-initialize the background and answers regions portion of +# the cross-correlation fitting structure for all regions and reset the +# current region to 1. + +procedure rg_xindefr (xc) + +pointer xc #I pointer to the cross-correlation structure + +int nregions +int rg_xstati() + +begin + nregions = rg_xstati (xc, NREGIONS) + + if (nregions > 0) { + call amovkr (INDEFR, Memr[XC_RZERO(xc)], nregions) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)], nregions) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)], nregions) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)], nregions) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)], nregions) + } + + XC_CREGION(xc) = 1 + XC_TXSHIFT(xc) = 0.0 + XC_TYSHIFT(xc) = 0.0 +end + + +# RG_XREALLOC -- Reallocate the regions bufffers and initialize if necessary. + +procedure rg_xrealloc (xc, nregions) + +pointer xc #I pointer to crosscor structure +int nregions #I number of regions + +int nr +int rg_xstati() + +begin + nr = rg_xstati (xc, NREGIONS) + + call realloc (XC_RC1(xc), nregions, TY_INT) + call realloc (XC_RC2(xc), nregions, TY_INT) + call realloc (XC_RL1(xc), nregions, TY_INT) + call realloc (XC_RL2(xc), nregions, TY_INT) + call realloc (XC_RZERO(xc), nregions, TY_REAL) + call realloc (XC_RXSLOPE(xc), nregions, TY_REAL) + call realloc (XC_RYSLOPE(xc), nregions, TY_REAL) + call realloc (XC_XSHIFTS(xc), nregions, TY_REAL) + call realloc (XC_YSHIFTS(xc), nregions, TY_REAL) + + call amovki (INDEFI, Memi[XC_RC1(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RC2(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RL1(xc)+nr], nregions - nr) + call amovki (INDEFI, Memi[XC_RL2(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RZERO(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RXSLOPE(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_RYSLOPE(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_XSHIFTS(xc)+nr], nregions - nr) + call amovkr (INDEFR, Memr[XC_YSHIFTS(xc)+nr], nregions - nr) +end + + +# RG_XFREE -- Free the cross-correlation fitting structure. + +procedure rg_xfree (xc) + +pointer xc #I pointer to the cross-correlation structure + +begin + # Free the region descriptors. + call rg_xrfree (xc) + + # Free the transformation descriptors. + if (XC_XREF(xc) != NULL) + call mfree (XC_XREF(xc), TY_REAL) + if (XC_YREF(xc) != NULL) + call mfree (XC_YREF(xc), TY_REAL) + if (XC_TRANSFORM(xc) != NULL) + call mfree (XC_TRANSFORM(xc), TY_REAL) + + # Free the correlation function. + if (XC_XCOR(xc) != NULL) + call mfree (XC_XCOR(xc), TY_REAL) + + call mfree (xc, TY_STRUCT) +end + + +# RG_XRFREE -- Free the regions portion of the cross-correlation structure. + +procedure rg_xrfree (xc) + +pointer xc #I pointer to the cross-correlation structure + +begin + call rg_xseti (xc, NREGIONS, 0) + if (XC_RC1(xc) != NULL) + call mfree (XC_RC1(xc), TY_INT) + XC_RC1(xc) = NULL + if (XC_RC2(xc) != NULL) + call mfree (XC_RC2(xc), TY_INT) + XC_RC2(xc) = NULL + if (XC_RL1(xc) != NULL) + call mfree (XC_RL1(xc), TY_INT) + XC_RL1(xc) = NULL + if (XC_RL2(xc) != NULL) + call mfree (XC_RL2(xc), TY_INT) + XC_RL2(xc) = NULL + if (XC_RZERO(xc) != NULL) + call mfree (XC_RZERO(xc), TY_REAL) + XC_RZERO(xc) = NULL + if (XC_RXSLOPE(xc) != NULL) + call mfree (XC_RXSLOPE(xc), TY_REAL) + XC_RXSLOPE(xc) = NULL + if (XC_RYSLOPE(xc) != NULL) + call mfree (XC_RYSLOPE(xc), TY_REAL) + XC_RYSLOPE(xc) = NULL + if (XC_XSHIFTS(xc) != NULL) + call mfree (XC_XSHIFTS(xc), TY_REAL) + XC_XSHIFTS(xc) = NULL + if (XC_YSHIFTS(xc) != NULL) + call mfree (XC_YSHIFTS(xc), TY_REAL) + XC_YSHIFTS(xc) = NULL +end + + +# RG_XSTATI -- Fetch the value of a cross-correlation fitting structure +# integer parameter. + +int procedure rg_xstati (xc, param) + +pointer xc #I pointer to the cross-correlation fitting structure +int param #I parameter to be fetched + +begin + switch (param) { + case CFUNC: + return (XC_CFUNC(xc)) + case IXLAG: + return (XC_IXLAG(xc)) + case IYLAG: + return (XC_IYLAG(xc)) + case XLAG: + return (XC_XLAG(xc)) + case YLAG: + return (XC_YLAG(xc)) + case DXLAG: + return (XC_DXLAG(xc)) + case DYLAG: + return (XC_DYLAG(xc)) + case XWINDOW: + return (XC_XWINDOW(xc)) + case YWINDOW: + return (XC_YWINDOW(xc)) + case CREGION: + return (XC_CREGION(xc)) + case NREGIONS: + return (XC_NREGIONS(xc)) + case BACKGRD: + return (XC_BACKGRD(xc)) + case BORDER: + return (XC_BORDER(xc)) + case FILTER: + return (XC_FILTER(xc)) + case XCBOX: + return (XC_XCBOX(xc)) + case YCBOX: + return (XC_YCBOX(xc)) + case PFUNC: + return (XC_PFUNC(xc)) + case NREFPTS: + return (XC_NREFPTS(xc)) + default: + call error (0, "RG_XSTATI: Undefined integer parameter.") + } +end + + +# RG_XSTATP -- Fetch the value of a pointer parameter. + +pointer procedure rg_xstatp (xc, param) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched + +begin + switch (param) { + case RC1: + return (XC_RC1(xc)) + case RC2: + return (XC_RC2(xc)) + case RL1: + return (XC_RL1(xc)) + case RL2: + return (XC_RL2(xc)) + case RZERO: + return (XC_RZERO(xc)) + case RXSLOPE: + return (XC_RXSLOPE(xc)) + case RYSLOPE: + return (XC_RYSLOPE(xc)) + case XSHIFTS: + return (XC_XSHIFTS(xc)) + case YSHIFTS: + return (XC_YSHIFTS(xc)) + case XCOR: + return (XC_XCOR(xc)) + case XREF: + return (XC_XREF(xc)) + case YREF: + return (XC_YREF(xc)) +# case CORAPODIZE: +# return (XC_CORAPODIZE(xc)) + case TRANSFORM: + return (XC_TRANSFORM(xc)) + default: + call error (0, "RG_XSTATP: Undefined pointer parameter.") + } +end + + +# RG_XSTATR -- Fetch the value of a real parameter. + +real procedure rg_xstatr (xc, param) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched + +begin + switch (param) { + case BVALUER: + return (XC_BVALUER(xc)) + case BVALUE: + return (XC_BVALUE(xc)) + case LOREJECT: + return (XC_LOREJECT(xc)) + case HIREJECT: + return (XC_HIREJECT(xc)) + case APODIZE: + return (XC_APODIZE(xc)) + case TXSHIFT: + return (XC_TXSHIFT(xc)) + case TYSHIFT: + return (XC_TYSHIFT(xc)) + default: + call error (0, "RG_XSTATR: Undefined real parameter.") + } +end + + +# RG_XSTATS -- Fetch the value of a string parameter. + +procedure rg_xstats (xc, param, str, maxch) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be fetched +char str[ARB] #O output value of string parameter +int maxch #I maximum number of characters in output string + +begin + switch (param) { + case BSTRING: + call strcpy (XC_BSTRING(xc), str, maxch) + case FSTRING: + call strcpy (XC_FSTRING(xc), str, maxch) + case CSTRING: + call strcpy (XC_CSTRING(xc), str, maxch) + case PSTRING: + call strcpy (XC_PSTRING(xc), str, maxch) + case REFIMAGE: + call strcpy (XC_REFIMAGE(xc), str, maxch) + case IMAGE: + call strcpy (XC_IMAGE(xc), str, maxch) + case OUTIMAGE: + call strcpy (XC_OUTIMAGE(xc), str, maxch) + case REGIONS: + call strcpy (XC_REGIONS(xc), str, maxch) + case DATABASE: + call strcpy (XC_DATABASE(xc), str, maxch) + case RECORD: + call strcpy (XC_RECORD(xc), str, maxch) + case REFFILE: + call strcpy (XC_REFFILE(xc), str, maxch) + default: + call error (0, "RG_XSTATS: Undefined string parameter.") + } +end + + +# RG_XSETI -- Set the value of an integer parameter. + +procedure rg_xseti (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +int value #O value of the integer parameter + +begin + switch (param) { + case CFUNC: + XC_CFUNC(xc) = value + switch (value) { + case XC_DISCRETE: + call strcpy ("discrete", XC_CSTRING(xc), SZ_FNAME) + case XC_FOURIER: + call strcpy ("fourier", XC_CSTRING(xc), SZ_FNAME) + case XC_FILE: + call strcpy ("file", XC_CSTRING(xc), SZ_FNAME) + case XC_DIFFERENCE: + call strcpy ("difference", XC_CSTRING(xc), SZ_FNAME) + default: + call strcpy ("unknown", XC_CSTRING(xc), SZ_FNAME) + } + case IXLAG: + XC_IXLAG(xc) = value + case IYLAG: + XC_IYLAG(xc) = value + case XLAG: + XC_XLAG(xc) = value + case YLAG: + XC_YLAG(xc) = value + case DXLAG: + XC_DXLAG(xc) = value + case DYLAG: + XC_DYLAG(xc) = value + case XWINDOW: + XC_XWINDOW(xc) = value + case YWINDOW: + XC_YWINDOW(xc) = value + case BACKGRD: + XC_BACKGRD(xc) = value + switch (value) { + case XC_BNONE: + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + case XC_MEAN: + call strcpy ("mean", XC_BSTRING(xc), SZ_FNAME) + case XC_MEDIAN: + call strcpy ("median", XC_BSTRING(xc), SZ_FNAME) + case XC_SLOPE: + call strcpy ("plane", XC_BSTRING(xc), SZ_FNAME) + default: + call strcpy ("none", XC_BSTRING(xc), SZ_FNAME) + } + case BORDER: + XC_BORDER(xc) = value + case FILTER: + XC_FILTER(xc) = value + switch (value) { + case XC_FNONE: + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + case XC_LAPLACE: + call strcpy ("laplace", XC_FSTRING(xc), SZ_FNAME) + default: + call strcpy ("none", XC_FSTRING(xc), SZ_FNAME) + } + case XCBOX: + XC_XCBOX(xc) = value + case YCBOX: + XC_YCBOX(xc) = value + case PFUNC: + XC_PFUNC(xc) = value + switch (value) { + case XC_PNONE: + call strcpy ("none", XC_PSTRING(xc), SZ_FNAME) + case XC_CENTROID: + call strcpy ("centroid", XC_PSTRING(xc), SZ_FNAME) + case XC_PARABOLA: + call strcpy ("parabolic", XC_PSTRING(xc), SZ_FNAME) + case XC_SAWTOOTH: + call strcpy ("sawtooth", XC_PSTRING(xc), SZ_FNAME) +# case XC_MARK: +# call strcpy ("mark", XC_PSTRING(xc), SZ_FNAME) + default: + ; + } + case NREFPTS: + XC_NREFPTS(xc) = value + case CREGION: + XC_CREGION(xc) = value + case NREGIONS: + XC_NREGIONS(xc) = value + default: + call error (0, "RG_XSETI: Undefined integer parameter.") + } +end + + +# RG_XSETP -- Set the value of a pointer parameter. + +procedure rg_xsetp (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +pointer value #O value of the pointer parameter + +begin + switch (param) { + case RC1: + XC_RC1(xc) = value + case RC2: + XC_RC2(xc) = value + case RL1: + XC_RL1(xc) = value + case RL2: + XC_RL2(xc) = value + case RZERO: + XC_RZERO(xc) = value + case RXSLOPE: + XC_RXSLOPE(xc) = value + case RYSLOPE: + XC_RYSLOPE(xc) = value + case XSHIFTS: + XC_XSHIFTS(xc) = value + case YSHIFTS: + XC_YSHIFTS(xc) = value + case XCOR: + XC_XCOR(xc) = value + case XREF: + XC_XREF(xc) = value + case YREF: + XC_YREF(xc) = value + case TRANSFORM: + XC_TRANSFORM(xc) = value +# case CORAPODIZE: +# XC_CORAPODIZE(xc) = value + default: + call error (0, "RG_XSETP: Undefined pointer parameter.") + } +end + + +# RG_XSETR -- Set the value of a real parameter. + +procedure rg_xsetr (xc, param, value) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +real value #O value of real parameter + +begin + switch (param) { + case BVALUER: + XC_BVALUER(xc) = value + case BVALUE: + XC_BVALUE(xc) = value + case LOREJECT: + XC_LOREJECT(xc) = value + case HIREJECT: + XC_HIREJECT(xc) = value + case APODIZE: + XC_APODIZE(xc) = value + case TXSHIFT: + XC_TXSHIFT(xc) = value + case TYSHIFT: + XC_TYSHIFT(xc) = value + default: + call error (0, "RG_XSETR: Undefined real parameter.") + } +end + + +# RG_XSETS -- Set the value of a string parameter. + +procedure rg_xsets (xc, param, str) + +pointer xc #I pointer to the cross-correlation structure +int param #I parameter to be set +char str[ARB] #O value of string parameter + +int index +pointer sp, temp +int strdic(), fnldir() + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + + switch (param) { + case BSTRING: + index = strdic (str, str, SZ_LINE, XC_BTYPES) + if (index > 0) { + call strcpy (str, XC_BSTRING(xc), SZ_FNAME) + call rg_xseti (xc, BACKGRD, index) + } + case FSTRING: + index = strdic (str, str, SZ_LINE, XC_FTYPES) + if (index > 0) { + call strcpy (str, XC_FSTRING(xc), SZ_FNAME) + call rg_xseti (xc, FILTER, index) + } + case CSTRING: + index = strdic (str, str, SZ_LINE, XC_CTYPES) + if (index > 0) { + call strcpy (str, XC_CSTRING(xc), SZ_FNAME) + call rg_xseti (xc, CFUNC, index) + } + case PSTRING: + call strcpy (str, XC_PSTRING(xc), SZ_FNAME) + case REFIMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], XC_REFIMAGE(xc), SZ_FNAME) + call strcpy (Memc[temp+index], XC_REFIMAGE(xc), SZ_FNAME) + case IMAGE: + call imgcluster (str, Memc[temp], SZ_FNAME) + index = fnldir (Memc[temp], XC_IMAGE(xc), SZ_FNAME) + call strcpy (Memc[temp+index], XC_IMAGE(xc), SZ_FNAME) + case OUTIMAGE: + call strcpy (str, XC_OUTIMAGE(xc), SZ_FNAME) + case REGIONS: + call strcpy (str, XC_REGIONS(xc), SZ_FNAME) + case DATABASE: + index = fnldir (str, XC_DATABASE(xc), SZ_FNAME) + call strcpy (str[index+1], XC_DATABASE(xc), SZ_FNAME) + case RECORD: + call strcpy (str, XC_RECORD(xc), SZ_FNAME) + case REFFILE: + index = fnldir (str, XC_REFFILE(xc), SZ_FNAME) + call strcpy (str[index+1], XC_REFFILE(xc), SZ_FNAME) + default: + call error (0, "RG_XSETS: Undefined string parameter.") + } + + call sfree (sp) +end diff --git a/pkg/images/immatch/src/xregister/rgxtransform.x b/pkg/images/immatch/src/xregister/rgxtransform.x new file mode 100644 index 00000000..63ee5f24 --- /dev/null +++ b/pkg/images/immatch/src/xregister/rgxtransform.x @@ -0,0 +1,446 @@ +include +include +include "xregister.h" + +# RG_GXTRANSFORM -- Open the reference points file and the read the +# coordinates of the reference points in the reference image. Return +# the reference points file name and descriptor. + +int procedure rg_gxtransform (list, xc, reffile) + +int list #I list of reference points files +pointer xc #I pointer to the cross-correlation structure +char reffile[ARB] #O the output reference points file name + +int tdf +pointer sp, line, pxref, pyref +real x1, y1, x2, y2, x3, y3 +int fntgfnb(), open(), getline(), nscan() +pointer rg_xstatp() + +begin + # Get some working memory. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + # Get the points to the reference point lists. + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + call aclrr (Memr[rg_xstatp(xc, XREF)], MAX_NREF) + call aclrr (Memr[rg_xstatp(xc, YREF)], MAX_NREF) + + # Open the reference points file and read the coordinates. + while (fntgfnb (list, reffile, SZ_FNAME) != EOF) { + + iferr { + + # Open the reference file. + tdf = open (reffile, READ_ONLY, TEXT_FILE) + call aclrr (Memr[pxref], MAX_NREF) + call aclrr (Memr[pyref], MAX_NREF) + + # Read up to three valid reference points from the list. + while (getline (tdf, Memc[line]) != EOF) { + call sscan (Memc[line]) + call gargr (x1) + call gargr (y1) + call gargr (x2) + call gargr (y2) + call gargr (x3) + call gargr (y3) + if (nscan () >= 2) + break + } + + # Store the reference points. + if (nscan () == 2) { + Memr[pxref] = x1 + Memr[pyref] = y1 + call rg_xseti (xc, NREFPTS, 1) + } else if (nscan () == 4) { + Memr[pxref] = x1 + Memr[pyref] = y1 + Memr[pxref+1] = x2 + Memr[pyref+1] = y2 + call rg_xseti (xc, NREFPTS, 2) + } else if (nscan () == 6) { + Memr[pxref] = x1 + Memr[pyref] = y1 + Memr[pxref+1] = x2 + Memr[pyref+1] = y2 + Memr[pxref+2] = x3 + Memr[pyref+2] = y3 + call rg_xseti (xc, NREFPTS, 2) + } else + call rg_xseti (xc, NREFPTS, 0) + + } then { + call rg_xseti (xc, NREFPTS, 0) + } + } + + call sfree (sp) + + return (tdf) +end + + +# RG_ITRANSFORM -- Compute the transformation from the input image to the +# reference image interactively. + +procedure rg_itransform (xc, imr, im, id) + +pointer xc #I pointer to the cross-correlation stucture +pointer imr #I pointer to the reference image +pointer im #I pointer to the input image +pointer id #I pointer to the display device + +int nref, nstar, wcs, key +pointer sp, cmd, x, y, pxref, pyref, ptrans +real wx, wy +int clgcur() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (x, MAX_NREF, TY_REAL) + call salloc (y, MAX_NREF, TY_REAL) + call aclrr (Memr[x], MAX_NREF) + call aclrr (Memr[y], MAX_NREF) + + # Get the pointers. + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + ptrans = rg_xstatp (xc, TRANSFORM) + + # Mark up to three reference stars. + nref = 0 + call printf ("Mark reference star %d with the image cursor [q=quit]: ") + call pargi (nref + 1) + while ((nref < MAX_NREF) && clgcur ("icommands", wx, wy, wcs, key, + Memc[cmd], SZ_LINE) != EOF) { + if (key == 'q') { + call printf ("\n") + break + } + if (wx < 0.5 || wx > IM_LEN(imr,1) + 0.5) { + call printf ("\n") + next + } + if (wy < 0.5 || wy > IM_LEN(imr,2) + 0.5) { + call printf ("\n") + next + } + call printf ("%g %g\n") + call pargr (wx) + call pargr (wy) + Memr[pxref+nref] = wx + Memr[pyref+nref] = wy + nref = nref + 1 + call rg_xseti (xc, NREFPTS, nref) + if (nref >= MAX_NREF) + break + call printf ( + "Mark reference star %d with the image cursor [q=quit]: ") + call pargi (nref + 1) + } + + # Mark the corresponding input image stars. + if (nref > 0) { + + nstar = 0 + call printf ("Mark image star %d with the image cursor [q=quit]: ") + call pargi (nstar + 1) + while ((nstar < nref) && clgcur ("icommands", wx, wy, wcs, key, + Memc[cmd], SZ_LINE) != EOF) { + if (key == 'q') { + call printf ("\n") + break + } + if (wx < 0.5 || wx > IM_LEN(im,1) + 0.5) { + call printf ("\n") + next + } + if (wy < 0.5 || wy > IM_LEN(im,2) + 0.5) { + call printf ("\n") + next + } + call printf ("%g %g\n") + call pargr (wx) + call pargr (wy) + Memr[x+nstar] = wx + Memr[y+nstar] = wy + nstar = nstar + 1 + if (nstar >= MAX_NREF) + break + call printf ( + "Mark image star %d with the image cursor [q=quit]: ") + call pargi (nstar + 1) + } + + # Compute the transformation. + if (nstar > 0) { + switch (nstar) { + case 0: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + case 1: + call rg_xshift (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + #case 2: + #call rg_xtwostar (Memr[x], Memr[y], Memr[pxref], + #Memr[pyref], Memr[ptrans]) + #case 3: + #call rg_xthreestar (Memr[x], Memr[y], Memr[pxref], + #Memr[pyref], Memr[ptrans]) + + default: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + } + } + } + + call sfree (sp) +end + + +# RG_XTRANSFORM -- Compute the transformation from the input image to +# the reference image + +procedure rg_xtransform (tfd, xc) + +int tfd #I the reference points file descriptor +pointer xc #I the cross-correlation file descriptor + +int nref +pointer sp, line, x, y, pxref, pyref, ptrans +int getline(), rg_xstati(), nscan() +pointer rg_xstatp() + +begin + # Allocate working space. + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (x, MAX_NREF, TY_REAL) + call salloc (y, MAX_NREF, TY_REAL) + call aclrr (Memr[x], MAX_NREF) + call aclrr (Memr[y], MAX_NREF) + + # Get the pointers to the reference image data. + nref = rg_xstati (xc, NREFPTS) + pxref = rg_xstatp (xc, XREF) + pyref = rg_xstatp (xc, YREF) + ptrans = rg_xstatp (xc, TRANSFORM) + + # Read the input image reference points. + while ((nref > 0) && getline (tfd, Memc[line]) != EOF) { + call sscan (Memc[line]) + call gargr (Memr[x]) + call gargr (Memr[y]) + call gargr (Memr[x+1]) + call gargr (Memr[y+1]) + call gargr (Memr[x+2]) + call gargr (Memr[y+2]) + if (nscan() >= 2 * nref) + break + } + + # Compute the transform. + if (nscan () < 2 * nref) { + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], Memr[pyref], + Memr[ptrans]) + } else { + switch (nref) { + case 0: + call rg_xshift (Memr[pxref], Memr[pyref], Memr[pxref], + Memr[pyref], Memr[ptrans]) + case 1: + call rg_xshift (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + case 2: + call rg_xtwostar (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + case 3: + call rg_xthreestar (Memr[x], Memr[y], Memr[pxref], Memr[pyref], + Memr[ptrans]) + } + } + + call sfree (sp) +end + + +# RG_ETRANSFORM -- Evaulate the current transform at a single point. + +procedure rg_etransform (xc, xin, yin, xout, yout) + +pointer xc #I pointer to the cross-correlation structure +real xin, yin #I the input x and y values +real xout, yout #O the output x and y values + +pointer ptrans +pointer rg_xstatp + +begin + ptrans = rg_xstatp (xc, TRANSFORM) + xout = Memr[ptrans] * xin + Memr[ptrans+1] * yin + Memr[ptrans+2] + yout = Memr[ptrans+3] * xin + Memr[ptrans+4] * yin + Memr[ptrans+5] +end + + +# RG_XSHIFT -- Compute the transformation coefficients required to define a +# simple shift using a single data point. + +procedure rg_xshift (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O output coefficient array + +begin + # Compute the x transformation. + coeff[1] = 1.0 + coeff[2] = 0.0 + coeff[3] = xref[1] - xlist[1] + + # Compute the y transformation. + coeff[4] = 0.0 + coeff[5] = 1.0 + coeff[6] = yref[1] - ylist[1] +end + + +# RG_XTWOSTAR -- Compute the transformation coefficients required to +# define a simple shift, magnification which is the same in x and y, +# and rotation using two data points. + +procedure rg_xtwostar (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O coefficient array + +real rot, mag, dxlis, dylis, dxref, dyref, cosrot, sinrot +real rg_xposangle() + +begin + # Compute the deltas. + dxlis = xlist[2] - xlist[1] + dylis = ylist[2] - ylist[1] + dxref = xref[2] - xref[1] + dyref = yref[2] - yref[1] + + # Compute the required rotation angle. + rot = rg_xposangle (dxref, dyref) - rg_xposangle (dxlis, dylis) + cosrot = cos (rot) + sinrot = sin (rot) + + # Compute the required magnification factor. + mag = dxlis ** 2 + dylis ** 2 + if (mag <= 0.0) + mag = 0.0 + else + mag = sqrt ((dxref ** 2 + dyref ** 2) / mag) + + # Compute the transformation coefficicents. + coeff[1] = mag * cosrot + coeff[2] = - mag * sinrot + coeff[3] = xref[1] - mag * cosrot * xlist[1] + mag * sinrot * ylist[1] + coeff[4] = mag * sinrot + coeff[5] = mag * cosrot + coeff[6] = yref[1] - mag * sinrot * xlist[1] - mag * cosrot * ylist[1] +end + + +# RG_THREESTAR -- Compute the transformation coefficients required to define +# x and y shifts, x and ymagnifications, a rotation and skew, and a possible +# axis flip using three tie points. + +procedure rg_xthreestar (xref, yref, xlist, ylist, coeff) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +real xlist[ARB] #I x input coordinates +real ylist[ARB] #I y input coordinates +real coeff[ARB] #O coefficient array + +real dx23, dx13, dx12, dy23, dy13, dy12, det +bool fp_equalr() + +begin + # Compute the deltas. + dx23 = xlist[2] - xlist[3] + dx13 = xlist[1] - xlist[3] + dx12 = xlist[1] - xlist[2] + dy23 = ylist[2] - ylist[3] + dy13 = ylist[1] - ylist[3] + dy12 = ylist[1] - ylist[2] + + # Compute the determinant. + det = xlist[1] * dy23 - xlist[2] * dy13 + xlist[3] * dy12 + if (fp_equalr (det, 0.0)) { + call rg_xtwostar (xref, yref, xlist, ylist, coeff) + return + } + + # Compute the x transformation. + coeff[1] = (xref[1] * dy23 - xref[2] * dy13 + xref[3] * dy12) / det + coeff[2] = (-xref[1] * dx23 + xref[2] * dx13 - xref[3] * dx12) / det + coeff[3] = (xref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + xref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + xref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det + + # Compute the y transformation. + coeff[4] = (yref[1] * dy23 - yref[2] * dy13 + yref[3] * dy12) / det + coeff[5] = (-yref[1] * dx23 + yref[2] * dx13 - yref[3] * dx12) / det + coeff[6] = (yref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + yref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + yref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det +end + + +# RG_XPOSANGLE -- Compute the position angle of a 2D vector. The angle is +# measured counter-clockwise from the positive x axis. + +real procedure rg_xposangle (x, y) + +real x #I x vector component +real y #I y vector component + +real theta +bool fp_equalr() + +begin + if (fp_equalr (y, 0.0)) { + if (x > 0.0) + theta = 0.0 + else if (x < 0.0) + theta = PI + else + theta = 0.0 + } else if (fp_equalr (x, 0.0)) { + if (y > 0.0) + theta = PI / 2.0 + else if (y < 0.0) + theta = 3.0 * PI / 2.0 + else + theta = 0.0 + } else if (x > 0.0 && y > 0.0) { # 1st quadrant + theta = atan (y / x) + } else if (x > 0.0 && y < 0.0) { # 4th quadrant + theta = 2.0 * PI + atan (y / x) + } else if (x < 0.0 && y > 0.0) { # 2nd quadrant + theta = PI + atan (y / x) + } else if (x < 0.0 && y < 0.0) { # 3rd quadrant + theta = PI + atan (y / x) + } + + return (theta) +end diff --git a/pkg/images/immatch/src/xregister/t_xregister.x b/pkg/images/immatch/src/xregister/t_xregister.x new file mode 100644 index 00000000..f9fc9b22 --- /dev/null +++ b/pkg/images/immatch/src/xregister/t_xregister.x @@ -0,0 +1,440 @@ +include +include +include +include +include "xregister.h" + +# T_XREGISTER -- Register a list of images using cross-correlation techniques. + +procedure t_xregister() + +pointer freglist # reference regions list +pointer database # the shifts database +int dformat # use the database format for the shifts file ? +int interactive # interactive mode ? +int verbose # verbose mode +pointer interpstr # interpolant type +int boundary # boundary extension type +real constant # constant for boundary extension + +int list1, listr, list2, reglist, reflist, reclist, tfd, stat, nregions +int c1, c2, l1, l2, ncols, nlines +pointer sp, image1, image2, imtemp, str, coords +pointer gd, id, imr, im1, im2, sdb, xc, mw +real shifts[2] +bool clgetb() +int imtopen(), imtlen(), imtgetim(), fntopnb(), clgwrd(), btoi() +int rg_xregions(), fntlenb(), rg_gxtransform(), rg_xstati() +int rg_xcorr(), rg_xicorr(), fntgfnb(), access(), open() +pointer gopen(), immap(), dtmap(), mw_openim() +real clgetr(), rg_xstatr() +errchk fntopnb(), gopen() + +begin + # Set STDOUT to flush on a newline character + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary working space. + call smark (sp) + + call salloc (freglist, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (database, SZ_FNAME, TY_CHAR) + call salloc (coords, SZ_FNAME, TY_CHAR) + call salloc (interpstr, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters and open lists. + call clgstr ("input", Memc[str], SZ_LINE) + list1 = imtopen (Memc[str]) + call clgstr ("reference", Memc[str], SZ_LINE) + listr = imtopen (Memc[str]) + call clgstr ("regions", Memc[freglist], SZ_LINE) + call clgstr ("shifts", Memc[database], SZ_FNAME) + call clgstr ("output", Memc[str], SZ_LINE) + list2 = imtopen (Memc[str]) + call clgstr ("records", Memc[str], SZ_LINE) + if (Memc[str] == EOS) + reclist = NULL + else + reclist = fntopnb (Memc[str], NO) + call clgstr ("coords", Memc[coords], SZ_LINE) + + # Open the cross correlation fitting structure. + call rg_xgpars (xc) + + # Test the reference image list length. + if (rg_xstati (xc, CFUNC) != XC_FILE) { + if (imtlen (listr) <= 0) + call error (0, "The reference image list is empty.") + if (imtlen (listr) > 1 && imtlen (listr) != imtlen (list1)) + call error (0, + "The number of reference and input images is not the same.") + if (Memc[coords] == EOS) + reflist = NULL + else { + reflist = fntopnb (Memc[coords], NO) + if (imtlen (listr) != fntlenb (reflist)) + call error (0, + "The number of reference point files and images is not the same.") + } + iferr { + reglist = fntopnb (Memc[freglist], NO) + } then { + reglist = NULL + } + call rg_xsets (xc, REGIONS, Memc[freglist]) + + } else { + call imtclose (listr) + listr = NULL + reflist = NULL + reglist = NULL + call rg_xsets (xc, REGIONS, "") + } + + # Close the output image list if it is empty. + if (imtlen (list2) == 0) { + call imtclose (list2) + list2 = NULL + } + + # Check that the output image list is the same size as the input + # image list. + if (list2 != NULL) { + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + if (list2 != NULL) + call imtclose (list2) + call error (0, + "The number of input and output images is not the same.") + } + } + + # Check that the record list is the same length as the input + # image list length. + if (reclist != NULL) { + if (fntlenb (reclist) != imtlen (list1)) + call error (0, + "Input image and record lists are not the same length.") + } + + + # Open the database file. + dformat = btoi (clgetb ("databasefmt")) + if (rg_xstati (xc, CFUNC) == XC_FILE) { + if (dformat == YES) + sdb = dtmap (Memc[database], READ_ONLY) + else + sdb = open (Memc[database], READ_ONLY, TEXT_FILE) + } else if (clgetb ("append")) { + if (dformat == YES) + sdb = dtmap (Memc[database], APPEND) + else + sdb = open (Memc[database], NEW_FILE, TEXT_FILE) + } else if (access (Memc[database], 0, 0) == YES) { + call error (0, "The shifts database file already exists") + } else { + if (dformat == YES) + sdb = dtmap (Memc[database], NEW_FILE) + else + sdb = open (Memc[database], NEW_FILE, TEXT_FILE) + } + call rg_xsets (xc, DATABASE, Memc[database]) + + # Get the boundary extension parameters for the image shift. + call clgstr ("interp_type", Memc[interpstr], SZ_FNAME) + boundary = clgwrd ("boundary_type", Memc[str], SZ_LINE, + "|constant|nearest|reflect|wrap|") + constant = clgetr ("constant") + + if (rg_xstati (xc, CFUNC) == XC_FILE) + interactive = NO + else + interactive = btoi (clgetb ("interactive")) + if (interactive == YES) { + call clgstr ("graphics", Memc[str], SZ_FNAME) + iferr (gd = gopen (Memc[str], NEW_FILE, STDGRAPH)) + gd = NULL + call clgstr ("display", Memc[str], SZ_FNAME) + iferr (id = gopen (Memc[str], APPEND, STDIMAGE)) + id = NULL + verbose = YES + } else { + if (rg_xstati (xc, PFUNC) == XC_MARK) + call rg_xseti (xc, PFUNC, XC_CENTROID) + gd = NULL + id = NULL + verbose = btoi (clgetb ("verbose")) + } + + # Initialize the reference image filter descriptors + imr = NULL + tfd = NULL + + # Initialize the overlap section. + c1 = INDEFI + c2 = INDEFI + l1 = INDEFI + l2 = INDEFI + ncols = INDEFI + nlines = INDEFI + + # Do each set of input, reference, and output images. + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF)) { + + # Open the reference image, and associated regions and coordinates + # files if the correlation function is not file. + + if (rg_xstati (xc, CFUNC) != XC_FILE) { + if (imtgetim (listr, Memc[str], SZ_FNAME) != EOF) { + if (imr != NULL) + call imunmap (imr) + imr = immap (Memc[str], READ_ONLY, 0) + if (IM_NDIM(imr) > 2) + call error (0, "Reference images must be 1D or 2D") + call rg_xsets (xc, REFIMAGE, Memc[str]) + nregions = rg_xregions (reglist, imr, xc, 1) + if (nregions <= 0 && interactive == NO) + call error (0, "The regions list is empty.") + if (reflist != NULL) { + if (tfd != NULL) + call close (tfd) + tfd = rg_gxtransform (reflist, xc, Memc[str]) + call rg_xsets (xc, REFFILE, Memc[str]) + } + } + } else + call rg_xsets (xc, REFIMAGE, "reference") + + # Open the input image. + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_NDIM(im1) > 2) { + call error (0, "Input images must be 1D or 2D") + } else if (imr != NULL) { + if (IM_NDIM(im1) != IM_NDIM(imr)) + call error (0, + "Input images must have same dimensionality as reference images") + } + call imseti (im1, IM_TYBNDRY, BT_NEAREST) + if (IM_NDIM(im1) == 1) + call imseti (im1, IM_NBNDRYPIX, IM_LEN(im1,1)) + else + call imseti (im1, IM_NBNDRYPIX, + max (IM_LEN(im1,1), IM_LEN(im1,2))) + call rg_xsets (xc, IMAGE, Memc[image1]) + + # Open the output image if any. + if (list2 == NULL) { + im2 = NULL + Memc[image2] = EOS + } else if (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF) { + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im2 = immap (Memc[image2], NEW_COPY, im1) + } else { + im2 = NULL + Memc[image2] = EOS + } + call rg_xsets (xc, OUTIMAGE, Memc[image2]) + + # Get the image record name for the shifts database. + if (reclist == NULL) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + else if (fntgfnb (reclist, Memc[str], SZ_FNAME) == EOF) + call strcpy (Memc[image1], Memc[str], SZ_FNAME) + call rg_xsets (xc, RECORD, Memc[str]) + + # Compute the initial coordinate shift. + if (tfd != NULL) + call rg_xtransform (tfd, xc) + + # Perform the cross correlation function. + if (interactive == YES) { + stat = rg_xicorr (imr, im1, im2, sdb, dformat, reglist, tfd, + xc, gd, id) + } else { + stat = rg_xcorr (imr, im1, sdb, dformat, xc) + if (verbose == YES) { + call rg_xstats (xc, REFIMAGE, Memc[str], SZ_LINE) + call printf ( + "Average shift from %s to %s is %g %g pixels\n") + call pargstr (Memc[image1]) + call pargstr (Memc[str]) + call pargr (rg_xstatr (xc, TXSHIFT)) + call pargr (rg_xstatr (xc, TYSHIFT)) + } + } + + # Compute the overlap region for the images. + call rg_overlap (im1, rg_xstatr (xc, TXSHIFT), + rg_xstatr (xc,TYSHIFT), c1, c2, l1, l2, ncols, nlines) + + # Shift the image and update the wcs. + if (im2 != NULL && stat == NO) { + if (verbose == YES) { + call printf ( + "\tShifting image %s to image %s ...\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imtemp]) + } + + call rg_xshiftim (im1, im2, rg_xstatr (xc, TXSHIFT), + rg_xstatr (xc, TYSHIFT), Memc[interpstr], boundary, + constant) + mw = mw_openim (im1) + shifts[1] = rg_xstatr (xc, TXSHIFT) + shifts[2] = rg_xstatr (xc, TYSHIFT) + call mw_shift (mw, shifts, 03B) + call mw_saveim (mw, im2) + call mw_close (mw) + } + + # Close up the input and output images. + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + if (stat == YES) + call imdelete (Memc[image2]) + else + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + if (stat == YES) + break + call rg_xindefr (xc) + } + + if (verbose == YES) + call rg_poverlap (c1, c2, l1, l2, ncols, nlines) + + call rg_xfree (xc) + + # Close up the lists. + if (imr != NULL) + call imunmap (imr) + call imtclose (list1) + if (listr != NULL) + call imtclose (listr) + if (reglist != NULL) + call fntclsb (reglist) + if (list2 != NULL) + call imtclose (list2) + if (tfd != NULL) + call close (tfd) + if (reflist != NULL) + call fntclsb (reflist) + if (reclist != NULL) + call fntclsb (reclist) + if (dformat == YES) + call dtunmap (sdb) + else + call close (sdb) + + # Close up the graphics and display devices. + if (gd != NULL) + call gclose (gd) + if (id != NULL) + call gclose (id) + + call sfree (sp) +end + + +# RG_OVERLAP -- Compute the overlap region of the list of images. + +procedure rg_overlap (im1, xshift, yshift, x1, x2, y1, y2, ncols, nlines) + +pointer im1 # pointer to the input image +real xshift # the computed x shift of the input image +real yshift # the computed y shift of the input image +int x1, x2 # the input/output column limits +int y1, y2 # the input/output line limits +int ncols, nlines # the input/output size limits + +int ixlo, ixhi, iylo, iyhi +real xlo, xhi, ylo, yhi + +begin + if (IS_INDEFR(xshift) || IS_INDEFR(yshift)) + return + + # Compute the limits of the shifted image. + xlo = 1.0 + xshift + xhi = IM_LEN(im1,1) + xshift + ylo = 1.0 + yshift + yhi = IM_LEN(im1,2) + yshift + + # Round up or down as appropriate. + ixlo = int (xlo) + if (xlo > ixlo) + ixlo = ixlo + 1 + ixhi = int (xhi) + if (xhi < ixhi) + ixhi = ixhi - 1 + iylo = int (ylo) + if (ylo > iylo) + iylo = iylo + 1 + iyhi = int (yhi) + if (yhi < iyhi) + iyhi = iyhi - 1 + + # Determine the new limits. + if (IS_INDEFI(x1)) + x1 = ixlo + else + x1 = max (ixlo, x1) + if (IS_INDEFI(x2)) + x2 = ixhi + else + x2 = min (ixhi, x2) + if (IS_INDEFI(y1)) + y1 = iylo + else + y1 = max (iylo, y1) + if (IS_INDEFI(y2)) + y2 = iyhi + else + y2 = min (iyhi, y2) + if (IS_INDEFI(ncols)) + ncols = IM_LEN(im1,1) + else + ncols = min (ncols, IM_LEN(im1,1)) + if (IS_INDEFI(nlines)) + nlines = IM_LEN(im1,2) + else + nlines = min (nlines, IM_LEN(im1,2)) +end + + +# RG_POVERLAP -- Procedure to print the overlap and/or vignetted region. + +procedure rg_poverlap (x1, x2, y1, y2, ncols, nlines) + +int x1, x2 # the input column limits +int y1, y2 # the input line limits +int ncols, nlines # the number of lines and columns + +int vx1, vx2, vy1, vy2 + +begin + vx1 = max (1, min (x1, ncols)) + vx2 = max (1, min (x2, ncols)) + vy1 = max (1, min (y1, nlines)) + vy2 = max (1, min (y2, nlines)) + + call printf ("Overlap region: [%d:%d,%d:%d]\n") + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + if (vx1 != x1 || vx2 != x2 || vy1 != y1 || vy2 != y2) { + call printf ("Vignetted overlap region: [%d:%d,%d:%d]\n") + call pargi (vx1) + call pargi (vx2) + call pargi (vy1) + call pargi (vy2) + } +end diff --git a/pkg/images/immatch/src/xregister/xregister.h b/pkg/images/immatch/src/xregister/xregister.h new file mode 100644 index 00000000..16c88b1e --- /dev/null +++ b/pkg/images/immatch/src/xregister/xregister.h @@ -0,0 +1,250 @@ +# Header file for XREGISTER + +# Define the cross correlation structure + +define LEN_XCSTRUCT (50 + 12 * SZ_FNAME + 12) + +define XC_RC1 Memi[$1] # pointers to 1st column of ref regions +define XC_RC2 Memi[$1+1] # pointers to 2nd column of ref regions +define XC_RL1 Memi[$1+2] # pointers to 1st line of ref regions +define XC_RL2 Memi[$1+3] # pointers to 2nd line of ref regions +define XC_RZERO Memi[$1+4] # pointers to zero pts of ref regions +define XC_RXSLOPE Memi[$1+5] # pointers to x slopes of ref regions +define XC_RYSLOPE Memi[$1+6] # pointers to y slopes of ref regions +define XC_XSHIFTS Memi[$1+7] # pointers to x shifts of ref regions +define XC_YSHIFTS Memi[$1+8] # pointers to y shifts of ref regions +define XC_NREGIONS Memi[$1+9] # total number of regions +define XC_CREGION Memi[$1+10] # the current region + +define XC_NREFPTS Memi[$1+11] # number of reference points +define XC_XREF Memi[$1+12] # pointer to x reference points +define XC_YREF Memi[$1+13] # pointer to y reference points +define XC_TRANSFORM Memi[$1+14] # pointer to the transform +define XC_IXLAG Memi[$1+15] # initial shift in x +define XC_IYLAG Memi[$1+16] # initial shift in y +define XC_XLAG Memi[$1+17] # current shift in x +define XC_YLAG Memi[$1+18] # current shift in y +define XC_DXLAG Memi[$1+19] # incremental shift in x +define XC_DYLAG Memi[$1+20] # incremental shift in y + +define XC_BACKGRD Memi[$1+21] # type of background subtraction +define XC_BORDER Memi[$1+22] # width of background border +define XC_BVALUER Memr[P2R($1+23)] # reference background value +define XC_BVALUE Memr[P2R($1+24)] # image bacground value +define XC_LOREJECT Memr[P2R($1+25)] # low side rejection +define XC_HIREJECT Memr[P2R($1+26)] # high side rejection +define XC_APODIZE Memr[P2R($1+27)] # fraction of apodized region +define XC_FILTER Memi[$1+28] # filter type + +define XC_CFUNC Memi[$1+30] # crosscor function +define XC_XWINDOW Memi[$1+31] # width of correlation window in x +define XC_YWINDOW Memi[$1+32] # width of correlation window in y +define XC_XCOR Memi[$1+33] # pointer to cross-correlation function + +define XC_PFUNC Memi[$1+34] # correlation peak fitting function +define XC_XCBOX Memi[$1+35] # x width of cor fitting box +define XC_YCBOX Memi[$1+36] # y width of cor fitting box + +define XC_TXSHIFT Memr[P2R($1+37)] # total x shift +define XC_TYSHIFT Memr[P2R($1+38)] # total y shift + +define XC_BSTRING Memc[P2C($1+50)] # background type +define XC_FSTRING Memc[P2C($1+50+SZ_FNAME+1)] # filter string +define XC_CSTRING Memc[P2C($1+50+2*SZ_FNAME+2)] # cross-correlation type +define XC_PSTRING Memc[P2C($1+50+3*SZ_FNAME+3)] # peak centering + +define XC_IMAGE Memc[P2C($1+50+4*SZ_FNAME+4)] # input image +define XC_REFIMAGE Memc[P2C($1+50+5*SZ_FNAME+5)] # reference image +define XC_REGIONS Memc[P2C($1+50+6*SZ_FNAME+6)] # regions list +define XC_DATABASE Memc[P2C($1+50+7*SZ_FNAME+7)] # shifts database +define XC_OUTIMAGE Memc[P2C($1+50+8*SZ_FNAME+8)] # output image +define XC_REFFILE Memc[P2C($1+50+9*SZ_FNAME+9)] # coordinates file +define XC_RECORD Memc[P2C($1+50+10*SZ_FNAME+10)] # record + +# Define the id strings + +define RC1 1 +define RC2 2 +define RL1 3 +define RL2 4 +define RZERO 5 +define RXSLOPE 6 +define RYSLOPE 7 +define XSHIFTS 8 +define YSHIFTS 9 +define NREGIONS 10 +define CREGION 11 + +define NREFPTS 12 +define XREF 13 +define YREF 14 +define TRANSFORM 15 +define IXLAG 16 +define IYLAG 17 +define XLAG 18 +define YLAG 19 +define DXLAG 20 +define DYLAG 21 + +define BACKGRD 22 +define BVALUER 23 +define BVALUE 24 +define BORDER 25 +define LOREJECT 26 +define HIREJECT 27 +define APODIZE 28 +define FILTER 29 + +define CFUNC 30 +define XWINDOW 31 +define YWINDOW 32 +define XCOR 33 + +define PFUNC 34 +define XCBOX 35 +define YCBOX 36 + +define TXSHIFT 37 +define TYSHIFT 38 + +define CSTRING 39 +define BSTRING 40 +define PSTRING 41 +define FSTRING 42 + +define IMAGE 43 +define REFIMAGE 44 +define REGIONS 45 +define OUTIMAGE 46 +define REFFILE 47 +define DATABASE 48 +define RECORD 49 + +# Define the default parameter values + +define DEF_IXLAG 0 +define DEF_IYLAG 0 +define DEF_DXLAG 0 +define DEF_DYLAG 0 +define DEF_XWINDOW 5 +define DEF_YWINDOW 5 + +define DEF_BACKGRD XC_BNONE +define DEF_BORDER INDEFI +define DEF_LOREJECT INDEFR +define DEF_HIREJECT INDEFR + +define DEF_XCBOX 5 +define DEF_YCBOX 5 +define DEF_PFUNC XC_CENTROID + +# Define the background fitting techniques + +define XC_BNONE 1 +define XC_MEAN 2 +define XC_MEDIAN 3 +define XC_SLOPE 4 + +define XC_BTYPES "|none|mean|median|plane|" + +# Define the filtering options + +define XC_FNONE 1 +define XC_LAPLACE 2 + +define XC_FTYPES "|none|laplace|" + +# Define the cross correlation techniques + +define XC_DISCRETE 1 +define XC_FOURIER 2 +define XC_DIFFERENCE 3 +define XC_FILE 4 + +define XC_CTYPES "|discrete|fourier|difference|file|" + +# Define the peak fitting functions + +define XC_PNONE 1 +define XC_CENTROID 2 +define XC_SAWTOOTH 3 +define XC_PARABOLA 4 +define XC_MARK 5 + +define XC_PTYPES "|none|centroid|sawtooth|parabola|mark|" + +# Miscellaneous + +define MAX_NREGIONS 100 +define MAX_NREF 3 +define MAX_NTRANSFORM 6 + +# Commands + +define XCMDS "|reference|input|regions|shifts|output|records|transform|\ +cregion|xlag|ylag|dxlag|dylag|background|border|loreject|hireject|apodize|\ +filter|correlation|xwindow|ywindow|function|xcbox|ycbox|show|mark|" + +define XSHOW "|data|background|correlation|center|" + +define XSHOW_DATA 1 +define XSHOW_BACKGROUND 2 +define XSHOW_CORRELATION 3 +define XSHOW_PEAKCENTER 4 + +define XCMD_REFIMAGE 1 +define XCMD_IMAGE 2 +define XCMD_REGIONS 3 +define XCMD_DATABASE 4 +define XCMD_OUTIMAGE 5 +define XCMD_RECORD 6 +define XCMD_REFFILE 7 +define XCMD_CREGION 8 +define XCMD_XLAG 9 +define XCMD_YLAG 10 +define XCMD_DXLAG 11 +define XCMD_DYLAG 12 +define XCMD_BACKGROUND 13 +define XCMD_BORDER 14 +define XCMD_LOREJECT 15 +define XCMD_HIREJECT 16 +define XCMD_APODIZE 17 +define XCMD_FILTER 18 +define XCMD_CORRELATION 19 +define XCMD_XWINDOW 20 +define XCMD_YWINDOW 21 +define XCMD_PEAKCENTER 22 +define XCMD_XCBOX 23 +define XCMD_YCBOX 24 +define XCMD_SHOW 25 +define XCMD_MARK 26 + +# Keywords + +define KY_REFIMAGE "reference" +define KY_IMAGE "input" +define KY_REGIONS "regions" +define KY_DATABASE "shifts" +define KY_OUTIMAGE "output" +define KY_RECORD "record" +define KY_REFFILE "coords" +define KY_NREGIONS "nregions" +define KY_CREGION "region" +define KY_XLAG "xlag" +define KY_YLAG "ylag" +define KY_DXLAG "dxlag" +define KY_DYLAG "dylag" +define KY_BACKGROUND "background" +define KY_BORDER "border" +define KY_LOREJECT "loreject" +define KY_HIREJECT "hireject" +define KY_APODIZE "apodize" +define KY_FILTER "filter" +define KY_CORRELATION "correlation" +define KY_XWINDOW "xwindow" +define KY_YWINDOW "ywindow" +define KY_PEAKCENTER "function" +define KY_XCBOX "xcbox" +define KY_YCBOX "ycbox" +define KY_TXSHIFT "xshift" +define KY_TYSHIFT "yshift" diff --git a/pkg/images/immatch/src/xregister/xregister.key b/pkg/images/immatch/src/xregister/xregister.key new file mode 100644 index 00000000..1956c88f --- /dev/null +++ b/pkg/images/immatch/src/xregister/xregister.key @@ -0,0 +1,47 @@ + Interactive Keystroke Commands + +? Print help +: Colon commands +t Define the offset between the reference and input images +c Draw a contour plot of the cross-correlation function +x Draw a column plot of the cross-correlation function +y Draw a line plot of the cross-correlation function +r Redraw the current plot +f Recompute the cross-correlation function +o Enter the image overlay plot submenu +w Update the task parameters +q Exit + + + Colon Commands + +:mark Mark regions on the display +:show Show current values of all the parameters + + + Show/set Parameters + +:reference [string] Show/set the current reference image name +:input [string] Show/set the current input image name +:regions [string] Show/set the regions to be cross-correlated +:shifts {string] Show/set the shifts database file name +:coords [string] Show/set the current coordinates file name +:output [string] Show/set the current output image name +:records [string] Show/set the current database record name +:xlag [value] Show/set the initial lag in x +:ylag [value] Show/set the initial lag in y +:dxlag [value] Show/set the incremental lag in x +:dylag [value] Show/set the incremental lag in y +:cregion [value] Show/set the current region +:background [string] Show/set the background fitting function +:border [value] Show/set border region for background fitting +:loreject [value] Show/set low side k-sigma rejection parameter +:hireject [value] Show/set high side k-sigma rejection parameter +:apodize [value] Show/set percent of end points to apodize +:filter [string] Show/set the default spatial filter +:correlation [string] Show/set the cross-correlation function +:xwindow [value] Show/set width of cross-correlation window in x +:ywindow [value] Show/set width of cross-correlation window in y +:function [string] Show/set correlation peak centering function +:xcbox [value] Show/set the centering box width in x +:ycbox [value] Show/set the centering box width in y diff --git a/pkg/images/immatch/sregister.cl b/pkg/images/immatch/sregister.cl new file mode 100644 index 00000000..38dc84ad --- /dev/null +++ b/pkg/images/immatch/sregister.cl @@ -0,0 +1,151 @@ +# SREGISTER -- Compute the geometric transformation required to register an +# input image to a reference image using celestial coordinate WCS information +# in the input and reference image headers, and perform the registration. +# SREGISTER is a simple script task which calls the SKYXYMATCH task to compute +# the control points, the GEOMAP task to compute the transformation, and the +# GEOTRAN task to do the registration. + +procedure sregister (input, reference, output) + +file input {prompt="The input images"} +file reference {prompt="Input reference images"} +file output {prompt="The output registered images"} +real xmin {INDEF, + prompt="Minimum logical x reference coordinate value"} +real xmax {INDEF, + prompt="Maximum logical x reference coordinate value"} +real ymin {INDEF, + prompt="Minimum logical y reference coordinate value"} +real ymax {INDEF, + prompt="Maximum logical y reference coordinate value"} +int nx {10, prompt="Number of grid points in x"} +int ny {10, prompt="Number of grid points in y"} +string wcs {"world", prompt="The default world coordinate system", + enum="physical|world"} +string xformat {"%10.3f", prompt="Output logical x coordinate format"} +string yformat {"%10.3f", prompt="Output logical y coordinate format"} +string rwxformat {"", + prompt="Output reference world x coordinate format"} +string rwyformat {"", + prompt="Output reference world y coordinate format"} +string wxformat {"", prompt="Output world x coordinate format"} +string wyformat {"", prompt="Output world y coordinate format"} + +string fitgeometry {"general", + prompt="Fitting geometry", + enum="shift|xyscale|rotate|rscale|rxyscale|general"} +string function {"polynomial", + prompt="Type of coordinate surface to be computed", + enum="legendre|chebyshev|polynomial"} +int xxorder {2, prompt="Order of x fit in x"} +int xyorder {2, prompt="Order of x fit in y"} +string xxterms {"half", enum="none|half|full", + prompt="X fit cross terms type"} +int yxorder {2, prompt="Order of y fit in x"} +int yyorder {2, prompt="Order of y fit in y"} +string yxterms {"half", enum="none|half|full", + prompt="Y fit cross terms type"} +real reject {INDEF, prompt="The rejection limit in units of sigma"} +string calctype {"real", prompt="Transformation computation type", + enum="real|double"} + +string geometry {"geometric", prompt="Transformation geometry", + enum="linear|geometric"} +real xsample {1.0,prompt="X coordinate sampling interval"} +real ysample {1.0,prompt="Y coordinate sampling interval"} +string interpolant {"linear", prompt="The interpolant type"} +string boundary {"nearest", prompt="Boundary extensiontype", + enum="nearest|constant|reflect|wrap"} +real constant {0.0, prompt="Constant for constant boundary extension"} +bool fluxconserve {yes, prompt="Preserve image flux ?"} +int nxblock {512, prompt="X dimension blocking factor"} +int nyblock {512, prompt="Y dimension blocking factor"} + +bool wcsinherit {yes, prompt="Inherit wcs of the reference image ?"} + +bool verbose {yes, prompt="Print messages about progress of task?"} +bool interactive {no, prompt="Compute transformation interactively? "} +string graphics {"stdgraph", prompt="The standard graphics device"} +gcur gcommands {"", prompt="The graphics cursor"} + + +begin + # Declare local variables. + int nimages + string tinput, treference, tcoords, tcname, tdatabase, toutput + string tsections1, tsections2 + + # Get the query parameters. + tinput = input + treference = reference + toutput = output + + # Cache the sections task. + cache sections + + # Get the coordinates file list. + tsections1 = mktemp ("tmps1") + tsections2 = mktemp ("tmps2") + if (access ("imxymatch.1")) { + tcoords = mktemp ("imxymatch") + } else { + tcoords = "imxymatch" + } + sections (tinput, option="fullname", > tsections1) + nimages = sections.nimages + for (i = 1; i <= nimages; i = i + 1) { + printf ("%s\n", tcoords // "." // i, >> tsections2) + } + delete (tsections1, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + tcname = "@"//tsections2 + + # Get the output database file name. + if (access ("sregister.db")) { + tdatabase = mktemp ("tmpdb") + } else { + tdatabase = "sregister.db" + } + + # Compute the control points. + skyxymatch (tinput, treference, tcname, coords="grid", xmin=xmin, + xmax=xmax, ymin=ymin, ymax=ymax, nx=nx, ny=ny, wcs=wcs, + xcolumn=1, ycolumn=1, xunits="", yunits="", xformat=xformat, + yformat=yformat, rwxformat=rwxformat, rwyformat=rwyformat, + wxformat=wxformat, wyformat=wyformat, min_sigdigits=7, verbose=no) + + # Compute the transformation. + geomap (tcname, tdatabase, xmin, xmax, ymin, ymax, transforms=tinput, + results="", fitgeometry=fitgeometry, function=function, + xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, + yyorder=yyorder, yxterms=yxterms, reject=reject, calctype=calctype, + verbose=verbose, interactive=interactive, graphics=graphics, + cursor=gcommands) + + # Register the images. + geotran (tinput, toutput, database=tdatabase, transforms=tinput, + geometry=geometry, xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, + xscale=1.0, yscale=1.0, ncols=INDEF, nlines=INDEF, + interpolant=interpolant, boundary=boundary, constant=constant, + fluxconserve=fluxconserve, xsample=xsample, ysample=ysample, + nxblock=nxblock, nyblock=nyblock, xin=INDEF, yin=INDEF, xout=INDEF, + yout=INDEF, xshift=INDEF, yshift=INDEF, xmag=INDEF, ymag=INDEF, + xrotation=INDEF, yrotation=INDEF, verbose=verbose) + + # Copy the reference wcs to the input images. + if (wcsinherit) { + wcscopy (toutput, treference, verbose-) + } + + # Delete the coordinates files. + delete (tcname, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + + # Delete the coordinates file list. + delete (tsections2, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + + # Delete the database file. + delete (tdatabase, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") +end diff --git a/pkg/images/immatch/wcscopy.par b/pkg/images/immatch/wcscopy.par new file mode 100644 index 00000000..a5bff29c --- /dev/null +++ b/pkg/images/immatch/wcscopy.par @@ -0,0 +1,5 @@ +# Parameter file for WCSCOPY + +images,f,a,,,,"List of input images" +refimages,f,a,,,,"List of reference images" +verbose,b,h,yes,,,"Print messages about actions taken ?" diff --git a/pkg/images/immatch/wcsmap.cl b/pkg/images/immatch/wcsmap.cl new file mode 100644 index 00000000..2a052dc0 --- /dev/null +++ b/pkg/images/immatch/wcsmap.cl @@ -0,0 +1,111 @@ +# WCSMAP -- Compute the geometric transformation required to register an +# input image to a reference image using WCS information in the input and +# reference image headers. WCSMAP is a simple script task which calls the +# WCSXYMATCH task to compute the control points followed by the GEOMAP +# task to compute the transformation. + + +procedure wcsmap (input, reference, database) + +file input {prompt="The input images"} +file reference {prompt="The input reference images"} +file database {prompt="The output database file"} +string transforms {"", prompt="The database transform names"} +string results {"", prompt="The optional results summary files"} +real xmin {INDEF, + prompt="Minimum logical x reference coordinate value"} +real xmax {INDEF, + prompt="Maximum logical x reference coordinate value"} +real ymin {INDEF, + prompt="Minimum logical y reference coordinate value"} +real ymax {INDEF, + prompt="Maximum logical y reference coordinate value"} +int nx {10, prompt="Number of grid points in x"} +int ny {10, prompt="Number of grid points in y"} +string wcs {"world", prompt="The default world coordinate system", + enum="physical|world"} +bool transpose {no, prompt="Force a world coordinate tranpose ?"} +string xformat {"%10.3f", prompt="Output logical x coordinate format"} +string yformat {"%10.3f", prompt="Output logical y coordinate format"} +string wxformat {"", prompt="Output world x coordinate format"} +string wyformat {"", prompt="Output world y coordinate format"} +string fitgeometry {"general", + prompt="Fitting geometry", + enum="shift|xyscale|rotate|rscale|rxyscale|general"} +string function {"polynomial", prompt="Surface type", + enum="legendre|chebyshev|polynomial"} +int xxorder {2, prompt="Order of x fit in x"} +int xyorder {2, prompt="Order of x fit in y"} +string xxterms {"half", enum="none|half|full", + prompt="X fit cross terms type"} +int yxorder {2, prompt="Order of y fit in x"} +int yyorder {2, prompt="Order of y fit in y"} +string yxterms {"half", enum="none|half|full", + prompt="Y fit cross terms type"} +real reject {INDEF, prompt="Rejection limit in sigma units"} +string calctype {"real", prompt="Computation precision", + enum="real|double"} +bool verbose {yes, prompt="Print messages about progress of task ?"} +bool interactive {yes, prompt="Compute transformation interactively ? "} +string graphics {"stdgraph", prompt="Default graphics device"} +gcur gcommands {"", prompt="Graphics cursor"} + + +begin + # Declare local variables. + int nimages + string tinput, treference, toutput, ttransforms, tresults, tcoords + string tsections1, tsections2, tcname + + # Cache the sections task. + cache sections + + # Get the query parameters. + tinput = input + treference = reference + toutput = database + if (transforms == "") { + ttransforms = tinput + } else { + ttransforms = transforms + } + tresults = results + + # Get the temporary coordinates file list. + tsections1 = mktemp ("tmps1") + tsections2 = mktemp ("tmps2") + if (access ("imxymatch.1")) { + tcoords = mktemp ("imxymatch") + } else { + tcoords = "imxymatch" + } + sections (tinput, option="fullname", > tsections1) + nimages = sections.nimages + for (i = 1; i <= nimages; i = i + 1) { + printf ("%s\n", tcoords // "." // i, >> tsections2) + } + delete (tsections1, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + tcname = "@"//tsections2 + + # Compute the control points. + wcsxymatch (tinput, treference, tcname, coords="grid", xmin=xmin, + xmax=xmax, ymin=ymin, ymax=ymax, nx=nx, ny=ny, wcs=wcs, + transpose=transpose, xcolumn=1, ycolumn=1, xunits="", yunits="", + xformat=xformat, yformat=yformat, wxformat=wxformat, + wyformat=wyformat, min_sigdigits=7, verbose=no) + + # Compute the transformation. + geomap (tcname, toutput, xmin, xmax, ymin, ymax, transforms=ttransforms, + results = tresults, fitgeometry=fitgeometry, function=function, + xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, + yyorder=yyorder, yxterms=yxterms, reject=reject, calctype=calctype, + verbose=verbose, interactive=interactive, graphics=graphics, + cursor=gcommands) + + # Cleanup. + delete (tcname, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + delete (tsections2, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") +end diff --git a/pkg/images/immatch/wcsxymatch.par b/pkg/images/immatch/wcsxymatch.par new file mode 100644 index 00000000..b7bab19e --- /dev/null +++ b/pkg/images/immatch/wcsxymatch.par @@ -0,0 +1,25 @@ +# Parameter file for the WCSXYMATCH task + +input,f,a,,,,Input images +reference,f,a,,,,Input reference images +output,f,a,,,,Output matched coordinate lists +coords,f,h,"grid",,,Reference coordinate lists +xmin,r,h,INDEF,,,Minimum logical x reference coordinate value +xmax,r,h,INDEF,,,Maximum logical x reference coordinate value +ymin,r,h,INDEF,,,Minimum logical y reference coordinate value +ymax,r,h,INDEF,,,Maximum logical y reference coordinate value +nx,i,h,10,1,,Number of grid points in x +ny,i,h,10,1,,Number of grid points in y +wcs,s,h,"world","|physical|world|",,Input coordinate system +transpose,b,h,no,,,Force a world coordinate transpose ? +xcolumn,i,h,1,1,,Input column containing x coordinate +ycolumn,i,h,2,1,,Input column containing y coordinate +xunits,s,h,"",,,Input x coordinate units +yunits,s,h,"",,,Input y coordinate units +xformat,s,h,"%10.3f",,,Output logical x coordinate format +yformat,s,h,"%10.3f",,,Output logical y coordinate format +wxformat,s,h,"",,,Output world x coordinate format +wyformat,s,h,"",,,Output world y coordinate format +min_sigdigits,i,h,7,,,Minimum number of significant digits +verbose,b,h,yes,,,Verbose mode ? +mode,s,h,ql,,, diff --git a/pkg/images/immatch/wregister.cl b/pkg/images/immatch/wregister.cl new file mode 100644 index 00000000..0817eeac --- /dev/null +++ b/pkg/images/immatch/wregister.cl @@ -0,0 +1,148 @@ +# WREGISTER -- Compute the geometric transformation required to register an +# input image to a reference image using WCS information in the input and +# reference image headers, and perform the registration. WREGISTER is a simple +# script task which calls the WCSXYMATCH task to compute the control points, +# the GEOMAP task to compute the transformation, and the GEOTRAN task to do +# the registration. + +procedure wregister (input, reference, output) + +file input {prompt="The input images"} +file reference {prompt="Input reference images"} +file output {prompt="The output registered images"} +real xmin {INDEF, + prompt="Minimum logical x reference coordinate value"} +real xmax {INDEF, + prompt="Maximum logical x reference coordinate value"} +real ymin {INDEF, + prompt="Minimum logical y reference coordinate value"} +real ymax {INDEF, + prompt="Maximum logical y reference coordinate value"} +int nx {10, prompt="Number of grid points in x"} +int ny {10, prompt="Number of grid points in y"} +string wcs {"world", prompt="The default world coordinate system", + enum="physical|world"} +bool transpose {no, prompt="Force a world coordinate tranpose ?"} +string xformat {"%10.3f", prompt="Output logical x coordinate format"} +string yformat {"%10.3f", prompt="Output logical y coordinate format"} +string wxformat {"", prompt="Output world x coordinate format"} +string wyformat {"", prompt="Output world y coordinate format"} + +string fitgeometry {"general", + prompt="Fitting geometry", + enum="shift|xyscale|rotate|rscale|rxyscale|general"} +string function {"polynomial", + prompt="Type of coordinate surface to be computed", + enum="legendre|chebyshev|polynomial"} +int xxorder {2, prompt="Order of x fit in x"} +int xyorder {2, prompt="Order of x fit in y"} +string xxterms {"half", enum="none|half|full", + prompt="X fit cross terms type"} +int yxorder {2, prompt="Order of y fit in x"} +int yyorder {2, prompt="Order of y fit in y"} +string yxterms {"half", enum="none|half|full", + prompt="Y fit cross terms type"} +real reject {INDEF, prompt="The rejection limit in units of sigma"} +string calctype {"real", prompt="Transformation computation type", + enum="real|double"} + +string geometry {"geometric", prompt="Transformation geometry", + enum="linear|geometric"} +real xsample {1.0,prompt="X coordinate sampling interval"} +real ysample {1.0,prompt="Y coordinate sampling interval"} +string interpolant {"linear", prompt="The interpolant type"} +string boundary {"nearest", prompt="Boundary extensiontype", + enum="nearest|constant|reflect|wrap"} +real constant {0.0, prompt="Constant for constant boundary extension"} +bool fluxconserve {yes, prompt="Preserve image flux ?"} +int nxblock {512, prompt="X dimension blocking factor"} +int nyblock {512, prompt="Y dimension blocking factor"} + +bool wcsinherit {yes, prompt="Inherit wcs of the reference image ?"} + +bool verbose {yes, prompt="Print messages about progress of task?"} +bool interactive {no, prompt="Compute transformation interactively? "} +string graphics {"stdgraph", prompt="The standard graphics device"} +gcur gcommands {"", prompt="The graphics cursor"} + + +begin + # Declare local variables. + int nimages + string tinput, treference, tcoords, tcname, tdatabase, toutput + string tsections1, tsections2 + + # Get the query parameters. + tinput = input + treference = reference + toutput = output + + # Cache the sections task. + cache sections + + # Get the coordinates file list. + tsections1 = mktemp ("tmps1") + tsections2 = mktemp ("tmps2") + if (access ("imxymatch.1")) { + tcoords = mktemp ("imxymatch") + } else { + tcoords = "imxymatch" + } + sections (tinput, option="fullname", > tsections1) + nimages = sections.nimages + for (i = 1; i <= nimages; i = i + 1) { + printf ("%s\n", tcoords // "." // i, >> tsections2) + } + delete (tsections1, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + tcname = "@"//tsections2 + + # Get the output database file name. + if (access ("wregister.db")) { + tdatabase = mktemp ("tmpdb") + } else { + tdatabase = "wregister.db" + } + + # Compute the control points. + wcsxymatch (tinput, treference, tcname, coords="grid", xmin=xmin, + xmax=xmax, ymin=ymin, ymax=ymax, nx=nx, ny=ny, wcs=wcs, + transpose=transpose, xcolumn=1, ycolumn=1, xunits="", yunits="", + xformat=xformat, yformat=yformat, wxformat=wxformat, + wyformat=wyformat, min_sigdigits=7, verbose=no) + + # Compute the transformation. + geomap (tcname, tdatabase, xmin, xmax, ymin, ymax, transforms=tinput, + results="", fitgeometry=fitgeometry, function=function, + xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, + yyorder=yyorder, yxterms=yxterms, reject=reject, calctype=calctype, + verbose=verbose, interactive=interactive, graphics=graphics, + cursor=gcommands) + + # Register the images. + geotran (tinput, toutput, database=tdatabase, transforms=tinput, + geometry=geometry, xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, + xscale=1.0, yscale=1.0, ncols=INDEF, nlines=INDEF, + interpolant=interpolant, boundary=boundary, constant=constant, + fluxconserve=fluxconserve, xsample=xsample, ysample=ysample, + nxblock=nxblock, nyblock=nyblock, xin=INDEF, yin=INDEF, xout=INDEF, + yout=INDEF, xshift=INDEF, yshift=INDEF, xmag=INDEF, ymag=INDEF, + xrotation=INDEF, yrotation=INDEF, verbose=verbose) + + # Copy the reference wcs to the input images. + if (wcsinherit) { + wcscopy (toutput, treference, verbose-) + } + + # Delete the coordinates files. + delete (tcname, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + + # Delete the coordinates file list. + delete (tsections2, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") + + # Delete the database file. + delete (tdatabase, go_ahead+, verify-, default_action+, + allversions+, subfiles+, > "dev$null") +end diff --git a/pkg/images/immatch/xregister.par b/pkg/images/immatch/xregister.par new file mode 100644 index 00000000..6e2da00b --- /dev/null +++ b/pkg/images/immatch/xregister.par @@ -0,0 +1,42 @@ +# Parameter file for the XREGISTER task + +input,s,a,,,,Input images to be registered +reference,s,a,,,,Input reference images +regions,s,a,"",,,Reference image regions used for registration +shifts,f,a,"",,,Input/output shifts database file +output,s,h,"",,,Output registered images +databasefmt,b,h,yes,,,Write the shifts file in database format ? +append,b,h,no,,,Open shifts database for writing in append mode ? +records,s,h,"",,,List of shifts database records +coords,f,h,"",,,Input coordinate files defining the initial shifts +xlag,i,h,0,,,Initial shift in x +ylag,i,h,0,,,Initial shift in y +dxlag,i,h,0,,,Incremental shift in x +dylag,i,h,0,,,Incremental shift in y + +background,s,h,"none","|none|mean|median|plane|",,Background fitting function +border,i,h,INDEF,,,Width of border for background fitting +loreject,r,h,INDEF,,,Low side k-sigma rejection factor +hireject,r,h,INDEF,,,High side k-sigma rejection factor +apodize,r,h,0.0,0.0,0.5,Fraction of endpoints to apodize +filter,s,h,"none","|none|laplace|",,Spatially filter the data + +correlation,s,h,"discrete","|discrete|fourier|difference|file|",,Cross-correlation function +xwindow,i,h,11,3,,Width of correlation window in x +ywindow,i,h,11,3,,Width of correlation window in y + +function,s,h,"centroid","|none|centroid|sawtooth|parabola|mark|",,Correlation peak centering function +xcbox,i,h,5,3,,X box width for centering correlation peak +ycbox,i,h,5,3,,Y box width for fitting correlation peak + +interp_type,s,h,"linear",,,'Interpolant' +boundary_type,s,h,"nearest","|constant|nearest|reflect|wrap|",,'Boundary (constant,nearest,reflect,wrap)' +constant,r,h,0.0,,,Constant for constant boundary extension + +interactive,b,h,no,,,Interactive mode ? +verbose,b,h,yes,,,Verbose mode ? +graphics,s,h,"stdgraph",,,The standard graphics device +display,s,h,"stdimage",,,The standard image display device +gcommands,*gcur,h,"",,,The graphics cursor +icommands,*imcur,h,"",,,The image display cursor +mode,s,h,ql,,, diff --git a/pkg/images/immatch/xyxymatch.par b/pkg/images/immatch/xyxymatch.par new file mode 100644 index 00000000..0a644e6d --- /dev/null +++ b/pkg/images/immatch/xyxymatch.par @@ -0,0 +1,36 @@ +# Parameter file for XYXYMATCH + +input,f,a,,,,The input lists +reference,f,a,,,,The reference lists +output,f,a,,,,The output matched coordinate lists +tolerance,r,a,3,,,The matching tolerance in pixels + +refpoints,f,h,"",,,Optional list of reference points +xin,r,h,INDEF,,,X origin of input list +yin,r,h,INDEF,,,Y origin of input list +xmag,r,h,INDEF,,,X magnification required to match input to reference list +ymag,r,h,INDEF,,,Y magnification required to match input to reference list +xrotation,r,h,INDEF,,,X rotation required to match input to reference list +yrotation,r,h,INDEF,,,Y rotation required to match input to reference list +xref,r,h,INDEF,,,X origin of reference list +yref,r,h,INDEF,,,Y origin of reference list + +xcolumn,i,h,1,,,Input list column containing the x coordinate +ycolumn,i,h,2,,,Input list column containing the y coordinate +xrcolumn,i,h,1,,,Reference list column containing the x coordinate +yrcolumn,i,h,2,,,Reference list column containing the y coordinate + +separation,r,h,9.0,,,The minimum object separation +matching,s,h,"triangles","|tolerance|triangles|",,The matching algorithm +nmatch,i,h,30,,,The maximum number of points for triangles algorithm +ratio,r,h,10.0,5.0,10.0,The maximum ratio of longest to shortest side of triangle +nreject,i,h,10,,,The maximum number of rejection iterations + +xformat,s,h,"%13.3f",,,The format of the output x coordinate +yformat,s,h,"%13.3f",,,The format of the output y coordinate + +interactive,b,h,no,,,Interactive mode ? +verbose,b,h,yes,,,Verbose mode ? +icommands,*imcur,h,"",,,The image display cursor + +mode,s,h,ql,,, diff --git a/pkg/images/imutil/Revisions b/pkg/images/imutil/Revisions new file mode 100644 index 00000000..706b483e --- /dev/null +++ b/pkg/images/imutil/Revisions @@ -0,0 +1,2045 @@ +.help revisions Jan97 images.imutil +.nf +pkg/images/imutil/imreplace.par +pkg/images/imutil/src/imrep.gx + Fixed a floating-point precision problem with short/int images in which + the lower cutoff could be rounded up. Also fixed a typo in the parameter + file. (9/22/99, MJF) + +pkg/images/imutil/src/t_imarith.x + Added a check for division by zero in the header keywords. + (8/10/99, Valdes) + +pkg/images/imutil/src/t_imreplace.x +pkg/images/imutil/src/imrep.gx +pkg/images/imutil/imreplace.par +pkg/images/imutil/doc/imreplace.hlp + Added a radius parameter to also replace any pixels within a specified + distance of pixels within the replacement window. (12/11/97, Valdes) + +===== +V2.11 +===== +=============================== +Package Reorganization +=============================== + +pkg/images/imarith/t_imsum.x +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imsum.hlp +pkg/images/doc/imcombine.hlp + Provided options for USHORT data. (12/10/96, Valdes) + +pkg/images/imarith/icsetout.x +pkg/images/doc/imcombine.hlp + A new option for computing offsets from the image WCS has been added. + (11/30/96, Valdes) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx + Changed the error checking to catch additional errors relating to too + many files. (11/12/96, Valdes) + +pkg/images/imarith/icsort.gx + There was an error in the ic_2sort routine when there are exactly + three images that one of the explicit cases did not properly keep + the image identifications. See buglog 344. (8/1/96, Valdes) + +pkg/images/filters/median.x + The routine mde_yefilter was being called with the wrong number of + arguments. + (7/18/96, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icombine.gx +pkg/images/imarith/icimstack.x + +pkg/images/imarith/iclog.x +pkg/images/imarith/mkpkg +pkg/images/doc/imcombine.hlp + The limit on the maximum number of images that can be combined, set by + the maximum number of logical file descriptors, has been removed. If + the condition of too many files is detected the task now automatically + stacks all the images in a temporary image and then combines them with + the project option. + (5/14/96, Valdes) + +pkg/images/geometry/xregister/rgxfit.x + Changed several Memr[] references to Memi[] in the rg_fit routine. + This bug was causing a floating point error in the xregister task + on the Dec Alpha if the coords file was defined, and could potentially + cause problems on other machines. + (Davis, April 3, 1996) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geograph.x +pkg/images/doc/geomap.hlp + Corrected the definition of skew in the routines which compute a geometric + interpretation of the 6-coefficient fit, which compute the coefficients + from the geometric parameters, and in the relevant help pages. + (2/19/96, Davis) + +pkg/images/median.par +pkg/images/rmedian.par +pkg/images/mode.par +pkg/images/rmode.par +pkg/images/fmedian.par +pkg/images/frmedian.par +pkg/images/fmode.par +pkg/images/frmode.par +pkg/images/doc/median.hlp +pkg/images/doc/rmedian.hlp +pkg/images/doc/mode.hlp +pkg/images/doc/rmode.hlp +pkg/images/doc/fmedian.hlp +pkg/images/doc/frmedian.hlp +pkg/images/doc/fmode.hlp +pkg/images/doc/frmode.hlp +pkg/images/filters/t_median.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_mode.x +pkg/images/filters/t_rmode.x +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_frmode.x + Added a verbose parameter to the median, rmedian, mode, rmode, fmedian, + frmedian, fmode, and frmode tasks. (11/27/95, Davis) + +pkg/images/geometry/doc/geotran.hlp + Fixed an error in the help page for geotran. The default values for + the xscale and yscale parameters were incorrectly listed as INDEF, + INDEF instead of 1.0, 1.0. (11/14/95, Davis) + +pkg/images/imarith/icpclip.gx + Fixed a bug where a variable was improperly used for two different + purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) + +pkg/images/doc/imcombine.hlp + Clarified a point about how the sigma is calculated with the SIGCLIP + option. (10/11/95, Valdes) + +pkg/images/imarith/icombine.gx + To deal with the case of readnoise=0. and image data which has points with + negative mean or median and very small minimum readnoise is set + internally to avoid computing a zero sigma and dividing by it. This + applies to the noise model rejection options. (8/11/95, Valdes) + +pkg/images/frmedian.hlp +pkg/images/frmode.hlp +pkg/images/rmedian.hlp +pkg/images/rmode.hlp +pkg/images/frmedian.par +pkg/images/frmode.par +pkg/images/rmedian.par +pkg/images/rmode.par +pkg/images/filters/frmedian.h +pkg/images/filters/frmode.h +pkg/images/filters/rmedian.h +pkg/images/filters/rmode.h +pkg/images/filters/t_frmedian.x +pkg/images/filters/t_frmode.x +pkg/images/filters/t_rmedian.x +pkg/images/filters/t_rmode.x +pkg/images/filters/frmedian.x +pkg/images/filters/frmode.x +pkg/images/filters/rmedian.x +pkg/images/filters/rmode.x +pkg/images/filters/med_utils.x + Added new ring median and modal filtering tasks frmedian, rmedian, + frmode, and rmode to the images package. + (6/20/95, Davis) + +pkg/images/fmedian.hlp +pkg/images/fmode.hlp +pkg/images/median.hlp +pkg/images/mode.hlp +pkg/images/fmedian.par +pkg/images/fmode.par +pkg/images/median.par +pkg/images/mode.par +pkg/images/filters/fmedian.h +pkg/images/filters/fmode.h +pkg/images/filters/median.h +pkg/images/filters/mode.h +pkg/images/filters/t_fmedian.x +pkg/images/filters/t_fmode.x +pkg/images/filters/t_median.x +pkg/images/filters/t_mode.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmode.x +pkg/images/filters/median.x +pkg/images/filters/mode.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_hist.x +pkg/images/filters/fmd_maxmin.x +pkg/images/filters/med_buf.x +pkg/images/filters/med_sort.x + Added minimum and maximum good data parameters to the fmedian, fmode, + median, and mode filtering tasks. Removed the 64X64 kernel size limit + in the median and mode tasks. Replaced the common blocks with structures + and .h files. + (6/20/95, Davis) + +pkg/images/geometry/t_geotran.x +pkg/images/geometry/geotran.x +pkg/images/geometry/geotimtran.x + Fixed a bug in the buffering of the x and y coordinate surface interpolants + which can cause a memory corruption error if, nthe nxsample or nysample + parameters are > 1, and the nxblock or nyblock parameters are less + than the x and y dimensions of the input image. Took the opportunity + to clean up the code. + (6/13/95, Davis) + +======= +V2.10.4 +======= + +pkg/images/geometry/t_geomap.x + Corrected a harmless typo in the code which determines the minimum + and maximum x values and improved the precision of the test when the + input is double precision. + (4/18/95, Davis) + +pkg/images/doc/fit1d.hlp + Added a description of the interactive parameter to the fit1d help page. + (4/17/95, Davis) + +pkg/images/imarith/t_imcombine.x + If an error occurs while opening an input image header the error + recovery will close all open images and then propagate the error. + For the case of running out of file descriptors with STF format + images this will allow the error message to be printed rather + than the error code. (4/3/95, Valdes) + +pkg/images/geometry/xregister/t_xregister.x + Added a test on the status code returned from the fitting routine so + the xregister tasks does not go ahead and write an output image when + the user quits the task in in interactive mode. + (3/31/95, Davis) + +pkg/images/imarith/icscale.x +pkg/images/doc/imcombine.hlp + The behavior of the weights when using both multiplicative and zero + point scaling was incorrect; the zero levels have to account for + the scaling. (3/27/95, Valdes) + +pkg/images/geometry/xregister/rgxtools.x + Changed some amovr and amovi calls to amovkr and amovki calls. + (3/15/95, Davis) + +pkg/images/geometry/t_imshift.x +pkg/images/geometry/t_magnify.x +pkg/images/geometry/geotran.x +pkg/images/geometry/xregister/rgximshift.x + The buffering margins set for the bicubic spline interpolants were + increased to improve the flux conservation properties of the interpolant + in cases where the data is undersampled. (12/6/94, Davis) + +pkg/images/xregister/rgxbckgrd.x + In several places the construct array[1++nx-wborder] was being used + instead of array[1+nx-wborder]. Apparently caused by a typo which + propagated through the code, the Sun compilers did not catch this, but + the IBM/RISC6000 compilers did. (11/16/94, Davis) + + +pkg/images/xregister.par +pkg/images/doc/xregister.hlp +pkg/images/geometry/xregister/t_xregister.x +pkg/images/geometry/xregister/rgxcorr.x +pkg/images/geometry/xregister/rgxicorr.x +pkg/images/geometry/xregister/rgxcolon.x +pkg/images/geometry/xregister/rgxdbio.x + The xregister task was modified to to write the output shifts file + in either text database format (the current default) or in simple text + format. The change was made so that the output of xregister could + both be edited more easily by the user and be used directly with the + imshift task. (11/11/94, Davis) + +pkg/images/imfit/fit1d.x + A Memc in the ratio output option was incorrectly used instead of Memr + when the bug fix of 11/16/93 was made. (10/14/94, Valdes) + +pkg/images/geometry/xregister/rgxcorr.x + The procedure rg_xlaplace was being incorrectly declared as an integer + procedure. + (8/1/94, Davis) + +pkg/images/geometry/xregister/rgxregions.x + The routine strncmp was being called (with a missing number of characters + argument) instead of strcmp. This was causing a bus error under solaris + but not sun os whenever the user set regions to "grid ...". (7/27/94 LED) + +pkg/images/tv/imexaine/ierimexam.x + The Gaussian fitting can return a negative sigma**2 which would cause + an FPE when the square root is taken. This will only occur when + there is no reasonable signal. The results of the gaussian fitting + are now set to INDEF if this unphysical result occurs. (7/7/94, Valdes) + +pkg/images/geometry/geofit.x + A routine expecting two char arrays was being passed two real arrays + instead resulting in a segmentation violation if calctype=real + and reject > 0. + (6/21/94, Davis) + +pkg/images/imarith/t_imarith.x + IMARITH now deletes the CCDMEAN keyword if present. (6/21/94, Valdes) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + 1. The restoration of deleted pixels to satisfy the nkeep parameter + was being done inside the iteration loop causing the possiblity + of a non-terminating loop; i.e. pixels are rejected, they are + restored, and the number left then does not statisfy the termination + condition. The restoration step was moved following the iterative + rejection. + 2. The restoration was also incorrectly when mclip=no and could + lead to a segmentation violation. + (6/13/94, Valdes) + +pkg/images/geometry/xregister/rgxicorr.x + The path names to the xregister task interactive help files was incorrect. + (6/13/94, Davis) + +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icsclip.gx + Found and fixed another typo bug. (6/7/94, Valdes/Zhang) + +pkg/images/imarith/icscale.x + The sigma scaling flag, doscale1, would not be set in the case of + a mean offset of zero though the scale factors could be different. + (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icsclip.gx + There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + The reordering step when a central median is used during rejection + but the final combining is average was incorrect if the number + of rejected low pixels was greater than the number of pixel + number of pixels not rejected. (5/25/94, Valdes) + +pkg/images/geometry/t_geotran.x + In cases where there was no input geomap database, geotran was + unnecessarily overiding the size of the input image requested by the + user if the size of the image was bigger than the default output size + (the size of the output image which would include all the input image + pixels is no user shifts were applied). + (5/10/94, Davis) + +pkg/images/imarith/icscale.x +pkg/images/imarith/t_imcombine.x + 1. There is now a warning error if the scale, zero, or weight type + is unknown. + 2. An sfree was being called before the allocated memory was finished + being used. + (5/2/94, Valdes) + +pkg/images/tv/imexaine/ierimexam.x + For some objects the moment analysis could fail producing a floating + overflow error in imexamine, because the code was trying to use + INDEF as the initial value of the object fwhm. Changed the gaussian + fitting code to use a fraction of the fitting radius as the initial value + for the fitted full-width half-maximum in cases where the moment analysis + cannot compute an initial value. + (4/15/94 LED) + +pkg/images/imarith/iclog.x + Changed the mean, median, mode, and zero formats from 6g to 7.5g to + insure 5 significant digits regardless of signs and decimal points. + (4/13/94, Valdes) + +pkg/images/doc/imcombine.hlp + Tried again to clarify the scaling as multiplicative and the offseting + as additive for file input and for log output. (3/22/94, Valdes) + +pkg/images/imarith/iacclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/iscclip.gx + The image sigma was incorrectly computed when an offset scaling is used. + (3/8/94, Valdes) + +pkg/images/doc/imcombine.hlp + The MINMAX example confused low and high. (3/7/94, Valdes) + +pkg/images/geometry/t_geomap.x +pkg/images/geometry/geofit.x +pkg/images/geometry/geograph.x + Fixed a bug in the geomap code which caused the linear portion of the transformation + to be computed incorrectly if the x and y fits had a different functional form. + (12/29/93, Davis) + +pkg/images/imarith/t_imcombine.x +pkg/images/imcombine.par +pkg/images/do/imcombine.hlp + The output pixel datatypes now include unsigned short integer. + (12/4/93, Valdes) + +pkg/images/doc/imcombine.hlp + Fixed an error in the example of offseting. (11/23/93, Valdes) + +pkg/images/imfit/fit1d.x + When doing operations in place the input and output buffers are the + same and the difference and ratio operations assumed they were not + causing the final results to be wrong. (11/16/93, Valdes) + +pkg/images/imarith/t_imarith.x +pkg/images/doc/imarith.hlp + If no calculation type is specified then it will be at least real + for a division. Since the output pixel type defaults to the + calculation type if not specified this will also result in a + real output if dividing two integer images. (11/12/93, Valdes) + +pkg/images/imarith/icgrow.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/t_imcombine.x +pkg/images/doc/imcombine.hlp + If there were fewer initial pixels than specified by nkeep then the + task would attempt to add garbage data to achieve nkeep pixels. This + could occur when using offsets, bad pixel masks, or thresholds. The + code was changed to check against the initial number of pixels rather + than the number of images. Also a negative nkeep is no longer + converted to a positive value based on the number of images. Instead + it specifies the maximum number of pixels to reject from the initial + set of pixels. (11/8/93, Valdes) + +======= +V2.10.2 +======= + +pkg/images/imarith/icsetout.x + Added MWCS calls to update the axis mapping when using the project + option in IMCOMBINE. (10/8/93, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/doc/imcombine.hlp + The help indicated that user input scale or zero level factors + by an @file or keyword are multiplicative and additive while the + task was using then as divisive and subtractive. This was + corrected to agree with the intend of the documentation. + Also the factors are no longer normalized. (9/24/93, Valdes) + +pkg$images/imarith/icsetout.x + The case in which absolute offsets are specified but the offsets are + all the same did not work correctly. (9/24/93, Valdes) + +pkg$images/imfit/imsurfit.h +pkg$images/imfit/t_imsurfit.x +pkg$images/imfit/imsurfit.x +pkg$images/lib/ranges.x + Fixed two bugs in the imsurfit task bad pixel rejection code. For low + k-sigma rejections factors the bad pixel list could overflow resulting + in a segmentation violation or a hung task. Overlapping ranges were + not being decoded into a bad pixel list properly resulting in + oscillating bad pixel rejection behavior where certain groups of + bad pixels were alternately being included and excluded from the fit. + Both bugs are fixed in iraf 2.10.3 + (9/21/93, Davis) + +pkg$images/doc/imcombine.hlp + Clarified how bad pixel masks work with the "project" option. + (9/13/93, Valdes) + +pkg$images/imfit/fit1d.x + When the input and output images are the same there was an typo error + such that the output was opened separately but then never unmapped + resulting in the end of the image not being updated. (8/6/93, Valdes) + +pkg$images/imarith/t_imcombine.x + The algorithm for making sure there are enough file descriptors failed + to account for the need to reopen the output image header for an + update. Thus when the number of input images + output images + logfile + was exactly 60 the task would fail. The update occurs when the output + image is unmapped so the solution was to close the input images first + except for the first image whose pointer is used in the new copy of the + output image. (8/4/93, Valdes) + +pkg$images/filters/t_mode.x +pkg$images/filters/t_median.x + Fixed a bug in the error trapping code in the median and mode tasks. + The call to eprintf contained an extra invalid error code agument. + (7/28/93, Davis) + +pkg$images/geometry/geomap.par +pkg$images/geometry/t_geomap.x +pkg$images/geometry/geogmap.x +pkg$images/geometry/geofit.x + Fixed a bug in the error handling code in geomap which was producing + a segmentation violation on exit if the user's coordinate list + had fewer than 3 data points. Also improved the error messages + presented to the user in both interactive and non-interactive mode. + (7/7/93, Davis) + +pkg$images/imarith/icgdata.gx + There was an indexing error in setting up the ID array when using + the grow option. This caused the CRREJECT/CCDCLIP algorithm to + fail with a floating divide by zero error when there were non-zero + shifts. (5/26/93, Valdes) + +pkg$images/imarith/icmedian.gx + The median calculation is now done so that the original input data + is not lost. This slightly greater inefficiency is required so + that an output sigma image may be computed if desired. (5/10/93, Valdes) + +pkg$images/geometry/t_imshift.x + Added support for type ushort to the imshift task in cases where the + pixel shifts are integral. + (5/8/93, Davis) + +pkg$images/doc/rotate.hlp + Fixed a bug in the rotate task help page which implied that automatic + image size computation would occur if ncols or nlines were set no 0 + instead of ncols and nlines. + (4/17/93, Davis) + +pkg$images/imarith/imcombine.gx + There was no error checking when writing to the output image. If + an error occurred (the example being when an imaccessible imdir was + set) obscure messages would result. Errchks were added. + (4/16/93, Valdes) + +pkg$images/doc/gauss.hlp + Fixed 2 sign errors in the equations in the documentation describing + the elliptical gaussian fucntion. + (4/13/92, Davis) + +pkg/images/imutil/t_imslice.x + Removed an error check in the imslice task, which was preventing it from + being used to reduce the dimensionality of images where the length of + the slice dimension is 1.0. + (2/16/83, Davis) + +pkg/images/filters/fmedian.x + The fmedian task was printing debugging information under iraf 2.10.2. + (1/25/93, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + When using mclip=yes and when more pixels are rejected than allowed by + the nkeep parameter there was a subtle bug in how the pixels are added + back which can result in a segmentation violation. + if (nh == n2) ==> if (nh == n[i]) + (1/20/93, Valdes) + + +======= +V2.10.1 +======= + +pkg/images/imarith/t_imcombine.x +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icgrow.gx +pkg/images/imarith/iclog.x +pkg/images/imarith/icombine.com +pkg/images/imarith/icombine.gx +pkg/images/imarith/icombine.h +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icscale.x +pkg/images/imarith/icsclip.gx +pkg/images/imarith/icsetout.x +pkg/images/imcombine.par +pkg/images/doc/combine.hlp + The weighting was changed from using the square root of the exposure time + or image statistics to using the values directly. This corresponds + to variance weighting. Other options for specifying the scaling and + weighting factors were added; namely from a file or from a different + image header keyword. The \fInkeep\fR parameter was added to allow + controlling the maximum number of pixels to be rejected by the clipping + algorithms. The \fIsnoise\fR parameter was added to include a sensitivity + or scale noise component to the noise model. Errors will now delete + the output image. + (9/30/92, Valdes) + +pkg/images/imutil/imcopy.x + Added a call to flush after the status line printout so that the output + will appear immediately. (8/19/92, Davis) + +pkg/images/filters/mkpkg +pkg/images/filters/t_fmedian.x +pkg/images/filters/fmedian.x +pkg/images/filters/fmd_buf.x +pkg/images/filters/fmd_maxmin.x + The fmedian task could crash with a segmentation violation if mapping + was turned off (hmin = zmin and hmax = zmax) and the input image + contained data outside the range defined by zmin and zmax. (8/18/92, Davis) + +pkg/images/imarith/icaclip.gx +pkg/images/imarith/iccclip.gx +pkg/images/imarith/icpclip.gx +pkg/images/imarith/icsclip.gx + There was a very unlikely possibility that if all the input pixels had + exactly the same number of rejected pixels the weighted average would + be done incorrectly because the dflag would not be set. (8/11/92, Valdes) + +pkg/images/imarith/icmm.gx + This procedure failed to set the dflag resulting in the weighted average + being computed in correctly. (8/11/92, Valdes) + +pkg/images/imfit/fit1d.x + At some point changes were made but not documented dealing with image + sections on the input/output. The changes seem to have left off the + final step of opening the output image using the appropriate image + sections. Because of this it is an error to use an image section + on an input image when the output image is different; i.e. + + cl> fit1d dev$pix[200:400,*] junk + + This has now been fixed. (8/10/92, Valdes) + +pkg/images/imarith/icscales.x + The zero levels were incorrectly scaled twice. (8/10/92, Valdes) + +pkg/images/imarith/icstat.gx + Contained the statement + nv = max (1., (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) + which is max(real,int). Changed the 1. to a 1. (8/10/92, Valdes) + +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx +pkg$images/imarith/icsclip.gx + These files contained multiple cases (ten or so) of constructs such as + "max (1., ...)" or "max (0., ...)" where the ... could be either real + or double. In the double cases the DEC compiler complained about a + type mismatch since 1. is real. (8/10/92, Valdes) + +pkg$images/imfit/t_imsurfit.x + Fixed a bug in the section reading code. Imsurfit is supposed to switch + the order of the section delimiters in x and y if x2 < x1 or y2 < 1. + Unfortunately the y test was actually "if (y2 < x1)" instead of + "if (y2 < y1)". Whether or not the code actually works correctly + depends on the value of x1 relative to y2. This bug was not present + in 2.9.1 but is present in subsequent releases. (7/30/92 LED) + +======= +V2.10.1 +======= + +pkg$images/filters/t_gauss.x + The case theta=90 and ratio > 0.0 but < 1.0 was producing an incorrect + convolution if bilinear=yes, because the major axis sigmas being + input along the x and y axes were sigma and ratio * sigma respectively + instead of ratio * sigma and sigma in this case. + +pkg$images/imutil/imcopy.x + Modified imcopy to write its verbose output to STDOUT instead of + STDERR. (6/24/92, Davis) + +pkg$images/imarith/imcombine.gx + The step where impl1$t is called to check if there is enough memory + did not set the return buffer because the values are irrelevant for + this check. However, depending on history, this buffer could have + arbitrary values and later when IMIO attempts to flush this buffer, + at least in the case of image type coersion, cause arithmetic errors. + The fix was to clear the returned buffers. (4/27/92, Valdes) + +pkg$images/imutil/t_imstack.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_imslice.x + Modified the imslice task to read the old and write a new axis map. + (4/23/92, Davis) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + Modified the calls to mw_shift and mw_scale to explicitly set the + number of logical axes instead of using the default of 0. + (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x + Modified imtranspose so that it correctly picks up the axis map + and writes it to the output image wcs. (4/23/92, Davis) + +pkg$images/register.par +pkg$images/geotran.par +pkg$images/doc/register.hlp +pkg$images/doc/geotran.hlp + Changed the default values of the parameters xscale and yscale in + the register and geotran tasks from INDEF to 1.0 (4/23/92, Davis) + +pkg$images/geometry/t_imtrans.x +pkg$images/doc/imtranspose.hlp + Modified the imtranspose task so it does a true transpose of the + axes instead of simply modifying the lterm. (4/8/92, Davis) + +pkg$images/iminfo/listpixels.x + Added the formats parameter for formatting the output pixel coordinates + to the listpixels task. These formats take precedence over the formats + stored in the WCS in the image header and the previous default format. + (4/7/92, Davis) + +pkg$images/imutil/t_imstack.x + Added wcs support to the imstack task. (4/2/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels so that it will work correctly if the dimension + of the wcs is less than the dimension of the image. (3/16/92, Davis) + +pkg$images/geometry/t_geotran.x + Modified the rotate, imlintran, register and geotran tasks wcs updating + code to deal correclty with dimensionally reduced data. (3/16/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/ipslip.gx +pkg$images/imarith/icslip.gx +pkg$images/imarith/icmedian.gx + The median calculation with an even number of points for short data + could overflow (addition of two short values) and be incorrect. + (3/16/92, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/t_blkrep.x + 1. Improved the precision of the blkavg task wcs updating code. + 2. Changed the blkrep task wcs updating code so that it is consistent + with blkavg. This means that a blkrep command followed by a blkavg + command or vice versa will return the original coordinate system + to within machine precision. (3/16/92, Davis) + +pkg$images/iminfo/listpixels.x + Modified listpixels to print out an error if it could not open the + wcs in the image. (3/15/92, Davis) + +pkg$images/geometry/t_magnify.x + Fixed a bug in the magnify task wcs updating code which was not + working correctly for dimensionally reduced images. (3/15/92, Davis) + +pkg$images/geometry/t_imtrans.x + Fixed a bug in the imtranspose task wcs updating code which was not + working correctly for dimensionally reduced images. (3/14/92, Davis) + +pkg$images/imarith/icalip.gx +pkg$images/imarith/icclip.gx +pkg$images/imarith/icslip.gx + There was a bug allowing the number of valid pixels counter to become + negative. Also there was a step which should not be done if the + number of valid pixels is less than 1; i.e. all pixels rejected. + A test was put in to skip this step. (3/13/92, Valdes) + +pkg$images/iminfo/t_imslice.x +pkg$images/doc/imslice.hlp + Added wcs support to the imslice task. + (3/12/92, Davis) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the code for computing the standard deviation, kurtosis, + and skew, wherein precision was being lost because two of the intermediate + variables in the computation were real instead of double precision. + (3/10/92, Davis) + +pkg$images/iminfo/listpixels.x + 1. Modified listpixels task to use the MWCS axis "format" attributes + if they are present in the image header. + 2. Added support for dimensionally reduced images, i.e. + images which are sections of larger images and whose coordinate + transformations depend on the reduced axes, to the listpixels task. + (3/6/92, Davis) + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/icsetout.x + Changed error messages to say IMCOMBINE instead of ICOMBINE. + (3/2/92, Valdes) + +pkg$images/imarith/iclog.x + Added listing of read noise and gain. (2/10/92, Valdes) + +pkg$images/imarith/icscale.x +pkg$images/imarith/icpclip.gx + 1. Datatype declaration for asumi was incorrect. + 2. Reduced the minimum number of images allowed for PCLIP to 3. + (1/7/92, Valdes) + +pkg$images/imarith/icgrow.gx + The first pixel to be checked was incorrectly set to 0 instead of 1 + resulting in a segvio when using the grow option. (12/6/91, Valdes) + +pkg$images/imarith/icgdata.gx +pkg$images/imarith/icscale.x + Fixed datatype declaration errors found by SPPLINT. (11/22/91, Valdes) + +pkg$images/iminfo/t_imstat.x + Fixed a bug in the kurtosis computation found by ST. + (Davis 10/11/91) + +pkg$images/iminfo/t_imstat.x +pkg$images/doc/imstat.hlp + Corrected a bug in the mode computation in imstatistics. The parabolic + interpolation correction for computing the histogram peak was being + applied in the wrong direction. Note that for dev$pix the wrong answer + is actually closer to the expected answer than the correct answer + due to binning effects. + (Davis 9/24/91) + +pkg$images/filters/t_gauss.x + The code which computes the gaussian kernel was producing a divide by + zero error if ratio=0.0 and bilinear=yes (2.10 version only). + (Davis 9/18/91) + +pkg$images/doc/magnify.hlp + Corrected a bug in the magnify help page. + (Davis 9/18/91) + +pkg$images/imarith/icsclip.gx +pkg$images/imarith/icaclip.gx +pkg$images/imarith/iccclip.gx + There was a typo, Memr[d[k]+k] --> Memr[d[j]+k]. (9/17/91, Valdes) + +pkg$images/imarith/icstat.gx +pkg$images/imarith/icmask.x + The offsets were used improperly in computing image statistics. + (Valdes, 9/17/91) + +pkg$images/geometry/t_imshift.x + The shifts file pointer was not being correctly initialized to NULL + in the case where no shifts file was declared. When the task + was invoked repeatedly from a script, this could result in an array being + referenced, for which space had not been previously allocated. + (Davis 7/29/91) + +pkg$images/imarith/imc* - +pkg$images/imarith/ic* + +pkg$images/imarith/t_imcombine.x +pkg$images/imarith/mkpkg +pkg$images/imarith/generic/mkpkg +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp + Replaced old version of IMCOMBINE with new version supporting masks, + offsets, and new algorithms. (Valdes 7/19/91) + +pkg$images/iminfo/imhistogram.x + Imhistogram has been modified to print the value of the middle of + histogram bin instead of the left edge if the output type is list + instead of plot. (Davis 6/11/91) + +pkg$images/t_imsurfit.x + Modified the sections file reading code to check the order of the + x1 x2 y1 y2 parameters and switch (x1,x2) or (y1,y2) if x2 < x1 or + y2 < y1 respectively. (Davis 5/28/91) + +pkg$images/listpixels.par +pkg$images/iminfo/listpixels.x +pkg$images/doc/listpixels.hlp + Modified the listpixels task to be able to print the pixel coordinates + in logical, physical or world coordinates. The default coordinate + system is still logical as before. (Davis 5/17/91) + +pkg$images/images.par +pkg$images/doc/minmax.hlp +pkg$images/imutil/t_minmax.x +pkg$images/imutil/minmax.x + Minmax was modified to do the minimum and maximum values computations + in double precision or complex instead of real if the input image + pixel type is double precision or complex. Note that the minimum and + maximum header values are still stored as real however. + (Davis 5/16/91) + +imarith/t_imarith.x + There was a missing statement to set the error flag if the image + dimensions did not match. (5/14/91, Valdes) + +doc/imarith.hlp + Fixed some formatting problems in the imarith help page. (5/2/91 Davis) + +imarith$imcombine.x + Changed the order in which images are unmapped to have the output images + closed last. This is to allow file descriptors for the temporary image + used when updating STF headers. (4/22/91, Valdes) + +pkg$images/geometry/t_blkavg.x +pkg$images/geometry/blkavg.gx +pkg$images/geometry/blkavg.x + The blkavg task was partially modified to support complex image data. + The full modifications cannot be made because of an error in abavx.x + and the missing routine absux.x. + (4/18/91 Davis) + +pkg$images/geometry/geofit.x + The x and y fits cross-terms switch was not being set correctly to "yes" + in the case where xxorder=2 and xyorder=2 or in the case where yxorder=2 + and yyorder=2. + (4/9/91 Davis) + +pkg$images/geometry/geogmap.x + Modified the line which prints the geometric parameters to use the + variable name xshift and yshift instead of delx and dely. + (4/9/91 Davis) + +pkg$images/imfit/imsurfit.x + Fixed a bug in the pixel rejection code which occurred when upper was > + 0.0 and lower = 0.0 or lower > 0 and upper = 0.0. The problem was that + the code was simply setting the rejection limits to the computed sigma + times the upper and lower parameters without checking for the 0.0 + condition first. In the first case this results in all points with + negative residuals being rejected and in the latter all points with + positive residuals are rejected. + (2/25/91 Davis) + +pkg$images/doc/hedit.hlp +pkg$images/doc/hselect.hlp +pkg$images/doc/imheader.hlp +pkg$images/doc/imgets.hlp + Added a reference to imgets in the SEE ALSO sections of the hedit and + hselect tasks. + Added a reference to hselect and hedit in the SEE ALSO sections of the + imheader and imgets tasks. + (2/22/91 Davis) + +pkg$images/gradient.hlp +pkg$images/laplace.hlp +pkg$images/gauss.hlp +pkg$images/convolve.hlp +pkg$images/gradient.par +pkg$images/laplace.par +pkg$images/gauss.par +pkg$images/convolve.par +pkg$images/t_gradient.x +pkg$images/t_laplace.x +pkg$images/t_gauss.x +pkg$images/t_convolve.x +pkg$images/convolve.x +pkg$images/xyconvolve.x +pkg$images/radcnv.x + The convolution operators were modified to run more efficiently in + certain cases. The LAPLACE task was modified to make use of the + radial symmetry of the convolution kernel in the y direction as well + as the x direction resulting in a modest speedup in execution time. + A new parameter bilinear was added to the GAUSS and CONVOLVE tasks. + By default and if appropriate mathematically, GAUSS now makes use of + the bilinearity or separability of the Gaussian function, + to separate the 2D convolution in x and y into two equivalent + 1D convolutions in x and y, resulting in a considerable speedup + in execution time. Similarly the user can know program CONVOLVE to + compute a bilinear convolution instead of a full 2D 1 if appropriate. + (1/29/91 Davis) + +pkg$images/filters/t_convolve.x + CONVOLVE was not decoding the legal 1D kernel "1.0 2.0 1.0" correctly + although the alternate form "1.0 2.0 1.0;" worked. Leading + blanks in string kernels as in for example " 1.0 2.0 1.0" also generated + and error. Fixed these bugs and added some additional error checking code. + (11/28/90 Davis) + +pkg$images/doc/gauss.hlp + Added a detailed mathematical description of the gaussian kernel used + by the GAUSS task to the help page. + +pkg$images/images.hd +pkg$images/rotate.cl +pkg$images/imlintran.cl +pkg$images/register.cl +pkg$images/register.par + Added src="script file name" entries to the IMAGES help database + for the tasks ROTATE, IMLINTRAN, and REGISTER. Changed the CL + script for REGISTER to a procedure script to remove the ugly + local variable declarations. Added a few comments to the scripts. + (12/11/90, Davis) + +pkg$images/iminfo/imhistogram.x + Added a new parameter binwidth to imhistogram. If binwidth is defined + it determines the histogram resolution in intensity units, otherwise + nbins determines the resolution as before. (10/26/90, Davis) + +pkg$images/doc/sections.hlp + Clarified what is meant by an image template and that the task itself + does not check whether the specified names are actually images. + The examples were improved. (10/3/90, Valdes) + +pkg$images/doc/fit1d.hlp + Changed lines to columns in example 2. (10/3/90, Valdes) + +pkg$images/imarith/imcscales.x + When an error occured while parsing the mode section the untrapped error + caused further problems downstream. Because it would require adding + lots of errchks to cause the program to gracefully abort I instead made + it a warning. (10/2/90, Valdes) + +pkg$images/imutil/hedit.x + Hedit was computing but not using min_lenarea. If the user specified + a min_lenuserarea greater than the default of 28800 then the default + was being used instead of the larger number. + +pkg$imarith/imasub.gx + The case of subtracting an image from the constant zero had a bug + which is now fixed. (8/14/90, Valdes) + +pkg$images/t_imtrans.x + Modified the imtranspose task so it will work on type ushort images. + (6/6/90 Davis) + +pkg$images + Added world coordinate system support to the following tasks: imshift, + shiftlines, magnify, imtranspose, blkrep, blkavg, rotate, imlintran, + register and geotran. The only limitation is that register and geotran + will only support simple linear transformations. + (2/24/90 Davis) + +pkg$images/geometry/geotimtran.x + Fixed a problem in the boundary extension "reflect" option code for small + images which was causing odd values to be inserted at the edges of the + image. + (2/14/90 Davis) + +pkg$images/iminfo/imhistogram.x + A new parameter "hist_type" was added to the imhistogram task giving + the user the option of plotting the integral, first derivative and + second derivative of the histogram as well as the normal histogram. + Code was contributed by Rob Seaman. + (2/2/90 Davis) + +pkg$images/geometry/geogmap.x + The path name of the help file was being erroneously renamed with + the result that when users ran the double precision version of the + code they could not find the help file. + (26/1/90 Davis) + +pkg$images/filters/t_boxcar.x,t_convolve.x + Added some checks for 1-D images. + (1/20/90 Davis) + +pkg$images/iminfo/t_imstat.x,imstat.h + Made several minor bug fixes and alterations in the imstatistics task + in response to user complaints and suggestions. + + 1. Changed the verbose parameter to the format parameter. If format is + "yes" (the default) then the selected fields are printed in fixed format + with column labels. Other wise the fields are printed in free format + separated by 2 blanks. This fixes the problem of fields running together. + + 2. Fixed a bug in the code which estimates the median from the image + histogram by linearly interpolating around the midpt of the integrated + histogram. The bug occurred when more than half the pixels were in the + first bin. + + 3. Added a check to ensure that the number of fields did not overflow + the fields array. + + 4. Removed the extraneous blank line printed after the title. + + 5. The pound sign is now printed at the beginning of the column header + string regardless of which field is printed first. In the previous + versions it was only being printed if the image name field was + printed first. + + 6. Changed the name of the median field to midpt in response to user + confusions about how the median is computed. + + (1/20/90, Davis) + +pkg$images/imutil/t_imslice.hlp + The imslice was not correctly computing the number of lines in the + output image in the case where the slice dimension was 1. + (12/4/89, Davis) + +pkg$images/doc/imcombine.hlp + Clarified and documented definitions of the scale, offset, and weights. + (11/30/89, Valdes) + +pkg$images/geometry/geotran.x + High order surfaces of a certain functional form could occasionally + produce out of bounds pixel errors. The bug was caused by not properly + computing the distortion of the image boundary for higher order + surfaces. + (11/21/89, Davis) + +pkg$images/geometry/imshift.x + The circulating buffer space was not being freed after each execution + of IMSHIFT. This did not cause an error in execution but for a long + list of frames could result in alot of memory being tied up. + (10/25/89, Davis) + +pkg$images/imarith/t_imarith.x + IMARITH is not prepared to deal with images sections in the output. + It used to look for '[' to decide if the output specification included + and image section. This has been changed to call the IMIO procedure + imgsection and check if a non-null section string is returned. + Thus it is up to IMIO to decide what part of the image name is + an image section. (9/5/89, Valdes) + +pkg$images/imarith/imcmode.gx + Fixed bug causing infinite loop when computing mode of constant value + section. (8/14/89, Valdes) + +==== +V2.8 +==== + +pkg$images/iminfo/t_imstat.x + Davis, Jun 15, 1989 + Added a couple of switches to that skew and kurtosis are not computed + if they are not to be printed. + +pkg$images/iminfo/t_imstat.x + Davis, Jun 14, 1989 + A simple mod was made to the skew and kurtosis computation to avoid + divide by zero errors in case of underflow. + +pkg$images/imutil/chpixtype.par + Davis, Jun 13, 1989 + The parameter file has been modified to accept an output pixel + type of ushort. + +pkg$images/imarith/imcombine.gx + Valdes, Jun 2, 1989 + A new scheme to detect file errors is now used. + +pkg$images/imfit/t_imsurfit.x + Davis, Jun 1, 1989 + 1. If the user set regions = "sections" but the sections file + did not exist the task would go into an infinite loop. The problem + was a missing error check on the open statement. + +pkg$images/iminfo/imhistogram.x,imhistogram.par + Davis, May 31, 1989 + A new version of imhistogram has been installed. These mods have + been made over a period of a month by Doug Tody and Rob Seaman. + The mods include + 1. An option to turn off log scaling of the y axis of the histogram plot. + 2. A new autoscale parameter which avoids aliasing problems for integer + data. + 3. A new parameter top_close which resolves the ambiguity in the top + bin of the histogram. + +pkg$images/imarith/imcombine.gx + Valdes, May 9, 1989 + Because a file descriptor was not reserved for string buffer operations + and a call to stropen in cnvdate was not error checked the task would + hang when more than 115 images were combined. Better error checking + was added and now an error message is printed when the maximum number + of images that can be combined is exceeded. + +pkg$images/imarith/t_imarith.x + Valdes, May 6, 1989 + Operations in which the output image has an image section are now + skipped with a warning message. + +pkg$images/imarith/sigma.gx +pkg$images/imarith/imcmode.gx + Valdes, May 6, 1989 + 1. The weighted sigma was being computed incorrectly. + 2. The argument declarations were wrong for integer input images. + Namely the mean vector is always real. + 3. Minor change to imcmode.gx to return correct datatype. + +pkg$images/imstack,imslice + Davis, April 1, 1989 + The proto images tasks imstack and imslice have been moved from the + proto package to the images package. Imstack is unchanged except that + it now supports the image data types USHORT and COMPLEX. Imslice has + been modified to allow slicing along any dimension of the image instead + of just the highest dimension. + +pkg$images/imstatistics. + Davis, Mar 31, 1989 + 1. A totally new version of the imstatistics task has been written + and replaces the old version. The new task allows the user to select + which statistical parameters to compute and print. These include + the mean, median, mode, standard deviation, skew, kurtosis and the + minimum and maximum pixel values. + +pkg$images/imhistogram.par +pkg$images/iminfo/imhistogram.x +pkg$images/doc/imhistogram.hlp + Davis, Mar 31, 1989 + 1. The imhistogram task has been modified to plot "box" style histograms + as well as "line" type histograms. Type "line" remains the default. + +pkg$images/geometry/geotran.par,register.par,geomap.par +pkg$images/doc/geomap.hlp,register.hlp,geotran.hlp + Davis, Mar 6, 1989 + 1. Improved the parameter prompting in GEOMAP, REGISTER and GEOTRAN + and improved the help pages. + 2. Changed GEOMAP database quantities "xscale" and "yscale" to "xmag" + and "ymag" for consistency . Geotran was changed appropriately. + +pkg$images/imarith/imcmode.gx + For short data a short variable was wraping around when there were + a significant number of saturated pixels leading to an infinite loop. + The variables were made real regardless of the image datatype. + (3/1/89, Valdes) + +pkg$images/imutil/imcopy.x + Davis, Feb 28, 1989 + 1. Added support for type USHORT to the imcopy task. This is a merged + ST modification. + +pkg$images/imarith/imcthreshold.gx +pkg$images/imcombine.par +pkg$images/doc/imcombine.hlp +pkg$images/imarith/imcscales.x + Valdes, Feb 16, 1989 + 1. Added provision for blank value when all pixels are rejected by the + threshold. + 2. Fixed a bug that was improperly scaling images in the threshold option. + 3. The offset printed in the log now has the opposite sign so that it + is the value "added" to bring images to a common level. + +pkg$images/imfit/imsurfit.x + Davis, Feb 23, 1989 + Fixed a bug in the median fitting code which could cause the porgram + to go into an infinite loop if the region to be fitted was less than + the size of the whole image. + +pkg$images/geometry/t_magnify.x + Davis, Feb 16, 1989 + Modified magnify to work on 1D images as well as 2D images. The + documentation has been updated. + +pkg$images/geometry/t_geotran.x + Davis, Feb 15, 1989 + Modified the GEOTRAN and REGISTER tasks so that they can handle a list + of transform records one for each input image. + +pkg$images/imarith/imcmode.gx + Valdes, Feb 8, 1989 + Added test for nx=1. + +pkg$images/imarith/t_imcombine.x + Valdes, Feb 3, 1989 + The test for the datatype of the output sigma image was wrong. + +pkg$images/iminfo/listpixels.x,listpixels.par + Davis, Feb 6, 1989 + The listpixels task has been modified to print out the pixels for a + list of images instead of a single image only. A title line for each + image listed can optionally be printed on the standard output if + the new parameter verbose is set to yes. + +pkg$images/geometry/t_imshift.x + Davis, Feb 2, 1989 + Added a new parameter shifts_file to the imshift task. Shifts_file + is the name of a text file containing the the x and yshifts for + each input image to be shifted. The number of input shifts must + equal the number of input images. + +pkg$images/geometry/t_geomap.x + Davis, Jan 17, 1989 + Added an error message for the case where the coordinates is empty + of there are no points in the specified data range. Previously the + task would proceed to the next coordinate file without any message. + +pkg$images/geometry/t_magnify.x + Davis, Jan 14, 1989 + Added the parameter flux conserve to the magnify task to bring it into + line with all the other geometric transformation tasks. + +pgk$images/geometry/geotran.x,geotimtran.x + Davis, Jan 2, 1989 + A bug was fixed in the flux conserve code. If the x and y reference + coordinates are not in pixel units and are not 1 then + the computed flux per pixel was too small by xscale * yscale. + +pkg$images/filters/acnvrr.x,convolve.x,boxcar.x,aboxcar.x + Davis, Dec 27, 1988 + I changed the name of the acnvrr procedure to cnv_radcnvr to avoid + a name conflict with a vops library procedure. This only showed + up when shared libraries were implemented. I also changed the name + of the aboxcarr procedure to cnv_aboxr to avoid conflict with the + vops naming conventions. + +pkg$images/imarith/imcaverage.gx + Davis, Dec 22, 1988 + Added an errchk statement for imc_scales and imgnl$t to stop the + program bombing with segmentation violations when mode <= 0. + +pkg$images/imarith/imcscales.x + Valdes, Dec 8, 1988 + 1. IMCOMBINE now prints the scale as a multiplicative quantity. + 2. The combined exposure time was not being scaled by the scaling + factors resulting in a final exposure time inconsistent with the + data. + +pkg$images/iminfo/imhistogram.x + Davis, Nov 30, 1988 + Changed the list+ mode so that bin value and count are printed out instead + of bin count and value. This makes the plot and list modes compatable. + +pkg$images/iminfo/t_imstat.x + Davis, Nov 17, 1988 + Added the n=n+1 back into the inner loop of imstat. + +pkg$images/geotran.par,register.par + Davis, Nov 11 , 1988 + Fixed to glaring errors in the parameter files for register and geotran. + Xscale and yscale were described as pixels per reference unit when + they should be reference units per pixel. The appropriate bug fix has been + made. + +pkg$images/geometry/t_geotran.x + Davis, November 7, 1988 + The routine gsrestore was not being error checked. If either of the + input x or y coordinate surface was linear and the other was not, + the message came back GSRESTORE: Illegal x coordinate. This bug has + been fixed. + +pkg$images/imarith/imcombine.gx + Valdes, October 19, 1988 + A vops clear routine was not called generically causing a crash with + double images. + +pkg$images/filters/t_fmedian.x,t_median.x,t_fmode.x,t_mode.x,t_gradient.x + t_gauss.x,t_boxcar.x,t_convolve.x,t_laplace.x + Davis, October 4, 1988 + I fixed a bug in the error handling code for the filters tasks. If + and error occurred during task execution and the input image name was + the same as the output image name then the input image was trashed. + +pkg$images/imarith/imcscales.gx + Valdes, September 28, 1988 + It is now an error for the mode to be nonpositive when scaling or weighting. + +pkg$images/imarith/imcmedian.gx + Valdes, August 16, 1988 + The median option was selecting the n/2 value instead of (n+1)/2. Thus, + for an odd number of images the wrong value was being determined for the + median. + +pkg$images/geometry/t_imshift.x + Davis, August 11, 1988 + 1. Imshift has been modified to uses the optimized code if nearest + neighbour interpolation is requested. A nint is done on the shifts + before calling the quick shift routine. + 2. If the requested pixel shift is too large imshift will now + clean up any pixelless header files before continuing execution. + +pkg$images/geometry/blkavg.gx + Davis, July 13, 1988 + Blkavg has been fixed so that it will work on 1D images. + +pkg$images/geometry/t_imtrans.x,imtrans.x + Davis, July 12, 1988 + Imtranspose has been modified to work on complex images. + +pkg$images/imutil/t_chpix.x + Davis, June 29, 1988 + A new task chpixtype has been added to the images package. Chpixtype + changes the pixel types of a list of images to a specified output pixel + type. Seven data types are supported "short", "ushort", "int", "long" + "real" and "double". + +pkg$images/geometry/rotate.cl,imlintran.cl,t_geotran.x + Davis, June 10, 1988 + The rotate and imlintran scripts have been rewritten to use procedure + scripts. This removes all the annoying temporary cl variables which + appear when the user does an lpar. In previous versions of these + two tasks the output was restricted to being the same size as the input + image. This is still the default case, but the user can now set the + ncols and nrows parameters to the desired output size. I ncols or nlines + < 0 then then the task compute the output image size required to contain + the whole input image. + +pkg$images/filters/t_convolve.x,t_laplace.x,t_gradient.x,t_gauss.x,convolve.x + Davis, June 1, 1988 + The convolution operators laplace, gauss and convolve have been modified + to make use of radial symmetry in the convolution kernel. In gauss and + laplace the change is transparent to the user. For the convolve operator + the user must indicate that the kernel is radially symmetric by setting + the parameter radsym. For kernels of 7 by 7 or greater the speedup + in timings is on the order of 30% on the Vax 750 with the fpa. + +pkg$images/imarith/imcmode.gx + Valdes, Apr 11, 1988 + 1. The use of a mode sections was handled incorrectly. + +pkg$images/imfit/fit1d.x + Valdes, Jan 4, 1988 + 1. Added an error check for a failure in IMMAP. The missing error check + caused FIT1D to hang when a bad input image was specified. + +pkg$images/magnify.par +pkg$images/imcombine.par +pkg$images/imarith/imcmode.gx +pkg$images/doc/imarith.hlp + Valdes, Dec 7, 1987 + 1. Added option list to parameter prompts. + 2. Fixed minor typo in help page + 3. The mode calculation in IMCOMBINE would go into an infinite loop + if all the pixel values were the same. If all the pixels are the + same them it skips searching for the mode and returns the constant + number. + +pkg$images/geometry/geotimtran.x + Davis, Nov 25, 1987 + 1. A bug in the boundary extension = wrap option was found in the + IMLINTRAN task. The problem occured in computing values for out of + bounds pixels in the range 0.0 < x < 1.0, ncols < x < ncols + 1.0, + 0.0 < y < 1.0 and nlines < y < nlines + 1. The computed coordinates + were falling outside the boundaries of the interpolation array. + +pkg$images/geometry/t_geomap.x,geograph.x + Davis, Nov 19, 1987 + 1. The geomap task now writes the name of the output file into the database. + 2. Rotation angles of 360. degrees have been altered to 0 degrees. + +pkg$images/imfit/t_imsurfit.x,imsurfit.x +pkg$images/lib/ranges.x + Davis, Nov 2, 1987 + A bug in the regions fitting option of the IMSURFIT task has been found + and fixed. This bug would occur when the user set the regions parameter + to sections and then listed section which overlapped each other. The + modified ranges package was not handling the overlap correctly and + computing a number of points which was incorrect. + +pkg$images/imarith/* + + Valdes, Sep 30, 1987 + The directory was reorganized to put generic code in the subdirectory + generic. + + A new task called IMCOMBINE has been added. It provides for combining + images by a number of algorithms, statistically weighting the images + when averaging, scaling or offsetting the images by the exposure time + or image mode before combining, and rejecting deviant pixels. It is + almost fully generic including complex images and works on images of + any dimension. + +pkg$images/geometry/geotran.x + Davis, Sept 3, 1987 + A bug in the flux conserving algorithm was found in the geotran code. + The symptom was that the flux of the output image occasionally was + negative. This would happen when two conditions were met, the transformation + was of higher order than a simple rotation, magnification, translation + and an axis flip was involved. The mathematical interpretation of this + bug is that the coordinate surface had turned upside down. The solution + for people running systems with this bug is to multiply there images + by -1. + +pkg$images/imfit/imsurfit.h,t_imsurfit.x + Davis, Aug 6, 1987 + A new option was added to the parameter regions in the imsurfit task. + Imsurfit will now fit a surface to a single circular region defined + by an x and y center and a radius. + +pkg$images/geometry/geotimtran.x + Davis, Jun 15, 1987 + Geotran and register were failing when the output image number of rows + and columns was different from the input number of rows and columns. + Geotran was mistakenly using the input images sizes to determine the + number of output lines that should be produced. The same problem occurred + when the values of the boundary pixels were being computed. The program + was using the output image dimensions to compute the boundary pixels + instead of the input image dimensions. + +pkg$images/geometry/geofit.x,geogmap.x + Davis, Jun 11, 1987 + A bug in the error checking code in the geomap task was fixed. The + condition of too few points for a reasonable was not being trapped + correctly. The appropriate errchk statements were added. + +pkg$images/geomap.par + Davis, Jun 10, 1987 + The default fitting function was changed to polynomial. This will satisfy + most users who wish to do shifts, rotations, and magnifications and + avoid the neccessity of correctly setting the xmin, xmax, ymin, and ymax + parameters. For the chebyshev and legendre polynomial functions these + parameters must be explicitly set. For reference coordinates in pixel + units the normal settings are 1, ncols, 1 and nlines respectively. + +pkg$images/iminfo/hselect.x,imheader.x,images$/imutil/hselect.x + Davis, Jun 8, 1987 + Imheader has been modified to open an image with the default min_lenuserarea + Hselect and hedit will now open the image setting the user area to the + maximum of 28800 chars or the min_lenuser environment variable. + +pkg$images/iminfo/t_imstat.x + Davis, May 22, 1987 + An error in the image minimum computation was corrected. This error + would show up most noiticeably if imstat was run on a 1 pixel image. + The min value would be left set to MAX_REAL. + +pkg$images/filters/mkpkg + Davis, May 22, 1987 + I added mach.h to the dependency file list of t_fmedian.x and + recompiled. The segmentation violations I had been getting in the + program disappeared. + +pkg$images/t_shiftlines.x,shiftlines.x + Davis, April 15, 1987 + 1. I changed the names of the procedures shiftlines and shiftlinesi + to sh_lines and sh_linesi. When the original names were contracted + to 6 letter fortran names they became shifti and shifts which just + so happens to collide with shifti and shifts in the subdirectory + osb. On VMS this was causing problems with the shareable libraries. + If images was linked with -z there was no problem. + +pkg$images/imarith/t_imsum.x + Valdes, March 24, 1987 + 1. IMSUM was failing to unmap images opened to check image dimensions + in a quick first pass through the image list. This is probably + the source of the out of files problem with STF images. It may + be the source of the out of memory problem reported from AOS/IRAF. + +pkg$images/imfit/fit1d.x +pkg$images/imfit/mkpkg + Valdes, March 17, 1987 + 1. Added error checking for the illegal operation in which both input + and output image had an image section. This was causing the task + to crash. The task now behaves properly in this circumstance and + even allows the fitted output to be placed in an image section of + an existing output image (even different than the input image + section) provided the input and output images have the same sizes. + +pkg$images/t_convolve.x + Davis, March 3, 1987 + 1. Fixed the kernel decoding routine in the convolve task so that + it now recognizes the row delimter character in string entry mode. + +pkg$images/geometry,filters + Davis, February 27, 1987 + 1. Changed all the imseti (im, TY_BNDRYPIXVAL, value) calls to imsetr. + +pkg$images/t_minmax.x,minmax.x + Davis, February 24, 1987 + 1. Minmax has been changed to compute the minimum and maximum pixel + as well as the minimum and maximum pixel values. The pixels are output + in section notation and stored in the minmax parameter file. + +pkg$images/t_magnify.x + Davis, February 19, 1987 + 1. Magnify was aborting with the error MSIFIT: Too few datapoints + when trying to reduce an image using the higher order interpolants + poly3, poly5 and spline3. I increased the NEDGE defined constant + from 2 to three and modified the code to use the out of bounds + imio. + +pkg$images/geograph.x,geogmap.x + Davis, February 17, 1987 + 1. Geomap now uses the gpagefile routine to page the .keys file. + The :show command deactivates the workstation before printing a + block of text and reactivates it when it is finished. + +pkg$images/geometry/geomap,geotran + Davis, January 26, 1987 + 1. There have been substantial changes to the geomap, and geotrans + tasks and those tasks rotate, imlintran and register which depend + on them. + 2. Geomap has been changed to be able to compute a transformation + in both single and double precision. + 3. The geotran code has been speeded up considerably. A simple rotate + now takes 70 seconds instead of 155 seconds using bilinear interpolation. + 4. Two new cl parameters nxblock and nyblock have been added to the + rotate, imlintran, register and geotran tasks. If the output image + is smaller than these parameters then the entire output image + is computed at once. Otherwise the output image is computed in blocks + nxblock by nyblock in size. + 5. The 3 geotran parameters rotation, scangle and flip have been replaced + with two parameters xrotation and yrotation which serve the same purpose. + +pkg$images/geometry/t_shiftlines.x,shiftlines.x + Davis, January 19, 1987 + 1. The shiftlines task has been completely rewritten. The following + are the major changes. + 2. Shiftlines now makes use of the imio boundary extension operations. + Therefore the four options: nearest pixel, reflect, wrap and constant + boundary extension are available. + 3. The interpolation code has been vectorised. The previous version + was using the function call asieval for every output pixel evaluated. + The asieval call were replaced with asivector calls. + 4. An extra CL parameter constant to support constant boundary + exension was added. + 5. The shiftlines help page was modified and the date changed to + January 1987. + +pkg$images/imfit/imsurfit.x + Davis, January 12, 1987 + 1. I changed the amedr call to asokr calls. For my application it did + not matter whether the input array is left partially sorted and the asokr + routine is more efficient. + +pkg$images/lib/pixlist.x + Davis, December 12, 1986 + 1. A bug in the pl_get_ranges routine caused the routine to fail when the + number of ranges got too large. The program could not detect the end of + the ranges and would go into an infinite loop. + +pkg$images/iminfo/t_imstat.x + Davis, December 3, 1986 + 1. Imstat was failing on constant images because finite machine precision + could result in a negative sigma squared. Added a check for this condition. + +pkg$images/filters/fmode.x + Davis, October 27, 1986 + 1. Added a check for 0 data range before calling amapr. + +pkg$images/imarith/imsum.gx + Valdes, October 20, 1986 + 1. Found and fixed bug in this routine which caused pixel rejection + to fail some fraction of the time. + +pkg$images/geometry/blkrp.gx + Valdes, October 13, 1986 + 1. There was a bug when the replication factor for axis 1 was 1. + +pkg$images/iminfo/imhistogram.x + Hammond, October 8, 1986 + 1. Running imhistogram on a constant valued image would result in + a "floating divide by zero fault" in ahgm. This condition is + now trapped and a warning printed if there is no range in the data. + +pkg$images/tv/doc/cvl.hlp + Valdes, October 7, 1986 + 1. Typo in V2.3 documentation fixed: "zcale" -> "zscale". + +pkg$images/fit1d.par + Valdes, October 7, 1986 + 1. When querying for the output type the query was: + +Type of output (fit, difference, ratio) (fit|difference|ratio) (): + + The enumerated values were removed since they are given in the + prompt string. + +pkg$images/imarith/t_imsum.x +pkg$images/imarith/imsum.gx +pkg$images/do/imsum.hlp + Valdes, October 7, 1986 + 1. Medians or pixel rejection with more than 15 images is now + correct. There was an error in buffering. + 2. Averages of integer datatype images are now correct. The error + was caused by summing the pixel values divided by the number + of images instead of summing the pixel values and then dividing + by the number of images. + 3. Option keywords may now be abbreviated. + 4. The output pixel datatype now defaults to the calculation datatype + as is done in IMARITH. The help page was modified to indicate this. + 5. Dynamic memory is now used throughout to reduce the size of the + executable. + 6. The bugs 1-2 are present in V2.3 and not in V2.2. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith.par +pkg$images/doc/imarith.hlp + Valdes, October 6, 1986 + 1. The parameter "debug" was changed to "noact". "debug" is reserved + for debugging information. + 2. The output pixel type now defaults to the calculation datatype. + 3. The datatype of constant operands is determined with LEXNUM. This + fixes a bug in which a constant such as "1." was classified as an + integer. + 4. Trailing whitespace in the string for a constant operand is allowed. + This fixes a bug with using "@" files created with the task FIELDS + from a table of numbers. Trailing whitespace in image names is + not checked for since this should be taken care of by lower level + system services. + 5. The reported bug with the "max" operation not creating a pixel file + was the result of the previous round of changes. This has been + corrected. This problem does not exist in the released version. + 6. All strings are now dynamically allocated. Also IMTOPENP is used + to open a CL list directly. + 7. The help page was revised for points (1) and (2). + +pkg$images/fmode.par +pkg$images/fmd_buf.x +pkg$images/med_sort.x + Davis, September 29, 1986 + 1. Changed the default value of the unmap parameter in fmode to yes. The + documentation was changed and the date modified. + 2. Added a test to make sure that the input image was not a constant + image in fmode and fmedian. + 3. Fixed the recently added swap macro in the sort routines which + was giving erroneous results for small boxes in tasks median and mode. + +pkg$images/imfit/fit1d.x + Valdes, September 24, 1986 + 1. Changed subroutine name with a VOPS prefix to one with a FIT1D + prefix. + +pkg$images/imarith/t_imdivide.x +pkg$images/doc/imdivide.hlp +pkg$images/imdivide.par + Valdes, September 24, 1986 + 1. Modified this ancient and obsolete task to remove redundant + subroutines now available in the VOPS library. + 2. The option to select action on zero divide was removed since + there was only one option. Parameter file changed. + 3. Help page revised. + +pkg$images/geometry/t_blkrep.x + +pkg$images/geometry/blkrp.gx + +pkg$images/geometry/blkrep.x + +pkg$images/doc/blkrep.hlp + +pkg$images/doc/mkpkg +pkg$images/images.cl +pkg$images/images.men +pkg$images/images.hd +pkg$images/x_images.x + Valdes, September 24, 1986 + 1. A new task called BLKREP for block replicating images has been added. + This task is a complement to BLKAVG and performs a function not + available in any other way. + 2. Help for BLKREP has been added. + +pkg$images/imarith/t_imarith.x +pkg$images/imarith/imadiv.gx +pkg$images/doc/imarith.hlp +pkg$images/imarith.par + Valdes, September 24, 1986 + 1. IMARITH has been modified to provide replacement of divisions + by zero with a constant parameter value. + 2. The documentation has been revised to include this change and to + clarify and emphasize areas of possible confusion. + +pkg$images/doc/magnify.hlp +pkg$images/doc/blkavg.hlp + Valdes, September 18, 1986 + 1. The MAGNIFY help document was expanded to clarify that images with axis + lengths of 1 cannot be magnified. Also a discussion of the output + size of a magnified image. This has been misunderstood often. + 2. Minor typo fix for BLKAVG. + +images$geometry/blkav.gx: Davis, September 7, 1986 + 1. The routine blkav$t was declared a function but called everywhere as + a procedure. Removed the function declaration. + +images$filters/med_sort.x: Davis, August 14, 1986 + 1. A bug in the sorting routine for MEDIAN and MODE in which the doop + loop increment was being set to zero has been fixed. This bug was + causing MEDIAN and MODE to fail on class 6 for certain sized windows. + +images$imfit/fit1d.x: Davis, July 24, 1986 + 1. A bug in the type=ratio option of fit1d was fixed. The iferr call + on the vector operator adivr was not trapping a divide by zero + condition. Changed adivr to adivzr. + +images$iminfo/listpixels.x: Davis, July 21, 1986 + 1. I changed a pargl to pargi for writing out the column number of the + pixels. + +images$iminfo/t_imstat.x: Davis, July 21, 1986 + 1. I changed a pargr to a pargd for the double precision quantitiies + sum(MIN) and sum(MAX). + +images$imfit/t_lineclean.x: Davis, July 14, 1986 + 1. Bug in the calling sequence for ic_clean fixed. The ic pointer + was not being passed to ic_clean causing access violation and/or + segmentation violation errors. + +images$imfit/fit1d.x, lineclean.x: Valdes, July 3, 1986 + 1. FIT1D and LINECLEAN modified to use new ICFIT package. + +From Valdes June 19, 1986 + +1. The help page for IMSUM was modified to explicitly state what the +median of an even number of images does. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986 + +1. A bug in CONVOLVE in which insufficient space was being allocated for +long (> 161 elements) 1D kernels has been fixed. CONVOLVE was not +allocating sufficent extra space. + +----------------------------------------------------------------------------- + +From Davis June 12, 1986 + +1. I have changed the default value of parameter unmap in task FMEDIAN to +yes to preserve the original data range. + +2. I have changed the value of parameter row_delimiter from \n to ;. + +----------------------------------------------------------------------------- + +From Davis May 12, 1986 + +1. Changed the angle convention in GAUSS so that theta is the angle of the +major axis with respect to the x axis measured counter-clockwise as specified +in the help page instead of the negative of that angle. + +----------------------------------------------------------------------------- + +From Davis Apr 28, 1986 + +1. Moved geomap.key to lib$scr and made redefined HELPFILE in geogmap.x +appropriately. + +------------------------------------------------------------------------------ + +images$imarith/imsum.gx: Valdes Apr 25, 1986 + 1. Fixed bug in generic code which called the real VOPS operator + regardless of the datatype. This caused IMSUM to fail on short + images. + +From Davis Apr 17, 1986 + +1. Changed constructs of the form boolean == false in the file imdelete.x +to ! boolean. + +------------------------------------------------------------------------------ + +images$imarith: Valdes, April 8, 1986 + 1. IMARITH has been modified to also operate on a list of specified + header parameters. This is primarily used when adding images to + also added the exposure times. A new parameter was added and the + help page modified. + 2. IMSUM has been modified to also operate on a list of specified + header parameters. This is primarily used when summing images to + also sum the exposure times. A new parameter was added and the + help page modified. + +------------------------------------------------------------------------------ + +From Valdes Mar 24, 1986: + +1. When modifying IMARITH to handle mixed dimensions the output image header +was made a copy of the image with the higher dimension. However, the default +when the images were of the same dimension changed to be a copy of the second +operand. This has been changed back to being a copy of the first operand +image. + +------------------------------------------------------------------------------ + +From Davis Mar 21, 1986: + +1. A NULL pointer bug in the subroutine plfree inside IMSURFIT was causing +segmentation violation errors. A null pointer test was added to plfree. + +------------------------------------------------------------------------------ + +From Davis Mar 20, 1986: + +1. A bug involving in place operations in several image tasks has been fixed. + +------------------------------------------------------------------------------ + +From Davis Mar 19, 1986: + +1. IMSURFIT no longer permits the input image to be replaced by the output +image. + +2. The tasks IMSHIFT, IMTRANSPOSE, SHIFTLINES, and GEOTRAN have been modified +to use the images tools xt_mkimtemp and xt_delimtemp for in place +calculations. + +------------------------------------------------------------------------------- + +From Valdes Mar 13, 1986: + +1. Bug dealing with type coercion in short datatype images in IMARITH and IMSUM +which occurs on the SUN has been fixed. +------ +From Valdes Mar 10, 1986: + +1. IMSUM has been modified to work on any number of images. + +2. Modified the help page +------ +From Valdes Feb 25, 1986: + +There have been two changes to IMARITH: + +1. A bug preventing use of image sections has been removed. + +2. An improvement allowing use of images of different dimension. +The algorithm is as follow: + + a. Check if both operands are images. If not the output + image is a copy of the operand image. + + b. Check that the axes lengths are the same for the dimensions + in common. For example a 3D and 2D image must have the same + number of columns and lines. + + c. Set the output image to be a copy of the image with the + higher dimension. + + d. Repeat the operation over the lower dimensions for each of + the higher dimensions. + +For example, consider subtracting a 2D image from a 3D image. The output +image will be 3D and the 2D image is subtracted from each band of the +3D image. This will work for any combination of dimensions. Another +example is dividing a 3D image by a 1D image. Then each line of each +plane and each band will be divided by the 1D image. Likely applications +will be subtracting biases and darks and dividing by response calibrations +in stacked observations. + +3. Modified the help page +=========== +Release 2.2 +=========== +From Davis Mar 6, 1986: + +1. A serious bug had crept into GAUSS after I made some changes. For 2D +images the sense of the sigma was reversed, i.e sigma = 2.0 was actually +sigma = 0.5. This bug has now been fixed. + +--------------------------------------------------------------------------- + +From Davis Jan 13, 1986: + +1. Listpixels will now print out complex pixel values correctly. + +--------------------------------------------------------------------------- + +From Davis Dec 12, 1985: + +1. The directional gradient operator has been added to the images package. + +--------------------------------------------------------------------------- + +From Valdes Dec 11, 1985: + +1. IMARITH has been modified to first check if an operand is an existing +file. This allows purely numeric image names to be used. + +--------------------------------------------------------------------------- + +From Davis Dec 11, 1985: + +1. A Laplacian (second derivatives) operator has been added to the images +package. + +--------------------------------------------------------------------------- + +From Davis Dec 10, 1985: + +1. The new convolution tasks boxcar, gauss and convolve have been added +to the images package. Convolve convolves an image with an arbitrary +user supplied rectangular kernel. Gauss convolves an image with a 2D +Gaussian of arbitrary size. Boxcar will smooth an image using a smoothing +window of arbitrary size. + +2. The images package source code has been reorganized into the following +subdirectories: 1) filters 2) geometry 3) imfit 4) imarith 4) iminfo and +5) imutil 6) lib. Lib contains routines which may be of use to several IRAF +tasks such as ranges. The imutil subdirectory contains tasks which modify +images in some way such as hedit. The iminfo subdirectory contains code +for displaying header and pixel values and other image characteristics +such as the histogram. Image arithmetic and fitting routines are found +in imarith and imfit respectively. Filters contains the convolution and +median filtering routines and geometry contains the geometric distortion +corrections routines. + +3. The documentation of the main images package has been brought into +conformity with the new IRAF standards. + +4. Documentation for imdelete, imheader, imhistogram, listpixels and +sections has been added to the help database. + +5. The parameter structure for imhistogram has been simplified. The +redundant parameters sections and setranges have been removed. + +--------------------------------------------------------------------------- + + +From Valdes Nov 4, 1985: + +1. IMCOPY modified so that the output image may be a directory. Previously +logical directories were not correctly identified. +------ + +From Davis Oct 21, 1985: + +1. A bug in the pixel rejection cycle of IMSURFIT was corrected. The routine +make_ranges in ranges.x was not successfully converting a sorted list of +rejected pixels into a list of ranges in all cases. + +2. Automatic zero divide error checking has been added to IMSURFIT. +------ +From Valdes Oct 17, 1985: + +1. Fit1d now allows averaging of image lines or columns when interactively +setting the fitting parameters. The syntax is "Fit line = 10 30"; i.e. +blank separated line or column numbers. A single number selects just one +line or column. Be aware however, that the actual fitting of the image +is still done on each column or line individually. + +2. The zero line in the interactive curve fitting graphs has been removed. +This zero line interfered with fitting data near zero. +------ +From Rooke Oct 10, 1985: + +1. Blkaverage was changed to "blkavg" and modified to support any allowed +number of dimensions. It was also made faster in most cases, depending on +the blocking factors in each dimension. +------ +From Valdes Oct 4, 1985: + +1. Fit1d and lineclean modified to allow separate low and high rejection +limits and rejection iterations. +------ +From Davis Oct 3, 1985: + +1. Minmax was not calculating the minimum correctly for integer images. +because the initial values were not being set correctly. +------ +From Valdes Oct 1, 1985: + +1. Imheader was modified to print the image history. Though the history +mechanism is little used at the moment it should become an important part +of any image. + +2. Task revisions renamed to revs. +------ +From Davis Sept 30, 1985: + +1. Two new tasks median and fmedian have been added to the images package. +Fmedian is a fast median filtering algorithm for integer data which uses +the histogram of the image to calculate the median at each window. Median +is a slower but more general algorithm which performs the same task. +------ +From Valdes August 26, 1985: + +1. Blkaverage has been modified to include an new parameter called option. +The current options are to average the blocks or sum the blocks. +------ +From Valdes August 7, 1985 + +1. Fit1d and lineclean wer recompiled with the modified icfit package. +The new package contains better labeling and graph documentation. + +2. The two tasks now have parameters for setting the graphics device +and reading cursor input from a file. +______ +From: /u2/davis/ Tue 08:27:09 06-Aug-85 +Package: images +Title: imshift bug + +Imshift was shifting incorrectly when an integral pixel shift in x and +a fractional pixel shift in y was requested. The actual x shift was +xshift + 1. The bug has been fixed and imshift will now work correctly for +any combination of fractional and integral pixel shifts +------ +From: /u2/davis/ Fri 18:14:12 02-Aug-85 +Package: images +Title: new images task + +A new task GEOMAP has been added to the images package. GEOMAP calculates +the spatial transformation required to map one image onto another. +------ +From: /u2/davis/ Thu 16:47:49 01-Aug-85 +Package: images +Title: new images tasks + +The tasks ROTATE, IMLINTRAN and GEODISTRAN have been added to the images +package. ROTATE rotates and shifts an image. IMLINTRAN will rotate, rescale +and shift an an image. GEODISTRAN corrects an image for geometric distortion. +------ +From Valdes July 26, 1985: + +1. The task revisions has been added to page revisions to the images +package. The intent is that each package will have a revisions task. +Note that this means there may be multiple tasks named revisions loaded +at one time. Typing revisions alone will give the revisions for the +current package. To get the system revisions type system.revisions. + +2. A new task called fit1d replaces linefit. It is essentially the same +as linefit except for an extra parameter "axis" which selects the axis along +which the functions are to be fit. Axis 1 is lines and axis 2 is columns. +The advantages of this change are: + + a. Column fitting can now be done without transposing the image. + This allows linefit to be used with image sections along + both axes. + b. For 1D images there is no prompt for the line number. +.endhelp diff --git a/pkg/images/imutil/_imaxes.par b/pkg/images/imutil/_imaxes.par new file mode 100644 index 00000000..833ca170 --- /dev/null +++ b/pkg/images/imutil/_imaxes.par @@ -0,0 +1,9 @@ +image,s,a,,,,image name +ndim,i,h +len1,i,h +len2,i,h +len3,i,h +len4,i,h +len5,i,h +len6,i,h +len7,i,h diff --git a/pkg/images/imutil/chpixtype.par b/pkg/images/imutil/chpixtype.par new file mode 100644 index 00000000..4302c427 --- /dev/null +++ b/pkg/images/imutil/chpixtype.par @@ -0,0 +1,8 @@ +# CHPIXTYPE + +input,f,a,,,,Input images +output,f,a,,,,Output images +newpixtype,s,a,,"|ushort|short|int|long|real|double|complex|",,Output pixel type +oldpixtype,s,h,"all","|all|ushort|short|int|long|real|double|complex|",,Input pixel type +verbose,b,h,y,,,Verbose mode +mode,s,h,'ql' diff --git a/pkg/images/imutil/doc/chpix.hlp b/pkg/images/imutil/doc/chpix.hlp new file mode 100644 index 00000000..9104b254 --- /dev/null +++ b/pkg/images/imutil/doc/chpix.hlp @@ -0,0 +1,64 @@ +.help chpixtype Jun88 images.imutil +.ih +NAME +chpixtype -- change the pixel type of an image +.ih +USAGE +chpixtype input output newpixtype +.ih +PARAMETERS +.ls input +The list of input images. +.le +.ls output +The list of output images. If the output image list is the same as the input +image list then the original images are overwritten. +.le +.ls newpixtype +The pixel type of the output image. The options are: "ushort", "short", +"int", "long", "real", "double" and "complex". +.le +.ls oldpixtype = "all" +The pixel type of the input images to be converted. By default all the +images in the input list are converted to the pixel type specified by +newpixtype. The remaining options are "ushort", "short", "int", "long", +"real", "double" and "complex" in which case only those images of the +specified type are converted. +.le +.ls verbose = yes +Print messages about actions performed. +.le + +.ih +DESCRIPTION + +The list of images specified by \fIinput\fR and pixel type \fIoldpixtype\fR +are converted to the pixel type specified by \fInewpixtype\fR and written +to the list of output images specified by \fIoutput\fR. + +Conversion from one pixel type to another is direct and may involve both +loss of precision and dynamic range. Mapping of floating point numbers +to integer numbers is done by truncation. Mapping of complex numbers +to floating point or integer numbers will preserve the real part of the +complex number only. + +.ih +EXAMPLES + +1. Convert a list of images to type real, overwriting the existing images. + + im> chpixtype nite1*.imh nite1*.imh real + +2. Convert only those images in imlist1 which are of type short to type real. + Imlist1 and imlist2 are text files containing the list of input and + output images respectively. The image names are listed 1 per line. + + im> chpixtype @imlist1 @imlist2 real old=short +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imarith +.endhelp diff --git a/pkg/images/imutil/doc/hedit.hlp b/pkg/images/imutil/doc/hedit.hlp new file mode 100644 index 00000000..3871d8e7 --- /dev/null +++ b/pkg/images/imutil/doc/hedit.hlp @@ -0,0 +1,375 @@ +.help hedit Apr01 images.imutil +.ih +NAME +hedit - edit or view an image header or headers +.ih +USAGE +hedit images fields value +.ih +PARAMETERS +.ls images +Template specifying the images to be edited. +.le +.ls fields +Template specifying the fields to be edited in each image. The template is +expanded independently for each image against the set of all fields in the +image header. +.le +.ls value +Either a string constant or a general expression (if the first character is +a left parenthesis) to be evaluated to compute the new value of each field. +A single expression is used for all fields. The special value "." causes the +value of each field to be printed rather than edited. +.le +.ls add = no +Change the operation of the editor from update to add new field. If the +field already exists it is edited. If this option is selected the field +list may name only a single field. The add switch takes precedence +over the addonly and delete switches. +.le +.ls addonly = no +Change the operation of the editor from update to add a new field. If the +field already exists it is not changed. If this option is selected the field +list may name only a single field. The addonly switch takes precedence over +the delete switch. +.le +.ls delete = no +Change the operation of the editor from update to delete field. +The listed fields are deleted from each image. +.le +.ls verify = yes +Interactively verify all operations which modify the image database. +The editor will describe the operation to be performed, prompting with the +new value of the parameter in the case of a field edit. Type carriage +return or "yes" to complete the operation, or enter a new value explicitly +as a string. Respond with "no" if you do not wish to change the value of +the parameter. +.le +.ls show = yes +Print a record of each operation which modifies the database upon the standard +output. Old values are given as well as new values, making it possible to +undo an edit operation. +.le +.ls update = yes +Enable updating of the image database. If updating is disabled the edit +operations are performed in memory but image headers will not be updated +on disk. +.le +.ih +DESCRIPTION + +1. Basic Usage + + The most basic functions of the image header editor are modification and +inspection of the fields of an image header. Both the "standard" and +"user" fields may be edited in the same fashion, although not all standard +fields are writable. For example, to change the value of the standard field +"title" of the image "m74" to "sky flat" we would enter the following command. + + cl> hedit m74 title "sky flat" + +If \fIverify\fR mode is selected the editor will print the old value of the +field and query with the new value, allowing some other value to be entered +instead, e.g.: + +.nf + cl> hedit m74 title "sky flat" + m74,i_title ("old title" -> "sky flat"): +.fi + +To accept the new value shown to the right of the arrow, type carriage +return or "yes" or "y" followed by carriage return. To continue without +changing the value of the field in question enter "no" or "n" followed by +carriage return. To enter some other value merely type in the new value. +If the new value is one of the reserved strings, e.g., "yes" or "no", +enter it preceded by a backslash. If verification is enabled you will +also be asked if you want to update the header, once all header fields +have been edited. This is your last chance to change your mind before +the header is modified on disk. If you respond negatively the image header +will not be updated, and editing will continue with the next image. +If the response is "q" the editor will exit entirely. + +To conveniently print the value of the field "title" without modifying the +image header, we repeat the command with the special value ".". + + cl> hedit m74 title . + +To print (or edit) the values of all header fields a field template may be +given. + + cl> hedit m74 * . + +To print (or edit) the values of only a few fields the field template may +be given as a list. + + cl> hedit m74 w0,wpc . + +To print the value of one or more fields in a set of images, an image template +may be given. Both image templates and field templates may be given if +desired. + + cl> hedit n1.* exp . + +Abbreviations are not permitted for field names, i.e., the given template +must match the full field name. Currently, field name matches are case +insensitive since image headers are often converted to and from FITS headers, +which are case insensitive. + + +2. Advanced Usage + + The header editor is capable of performing global edits on entire image +databases wherein the new value of each field is computed automatically at +edit time and may depend on the values of other fields in the image header. +Editing may be performed in either batch or interactive mode. An audit trail +may be maintained (via the \fIshow\fR switch and i/o redirection), permitting +restoration of the database in the event of an error. Trial runs may be made +with updating disabled, before committing to an actual edit which modifies the +database. + +The major editing functions of the \fIhedit\fR task are the following: + +.nf + update modify the value of a field or fields + addonly add a new field + add add a new field or modify an old one + delete delete a set of fields +.fi + +In addition, \fIhedit\fR may be used merely to inspect the values of the header +fields, without modification of the image database. + + +2.1 Standard header fields + + The header editor may be used to access both the standard image header +fields and any user or application defined fields. The standard header fields +currently defined are shown below. There is no guarantee that the names and/or +usage of these fields will not change in the future. + + +.ks +.nf + i_ctime int create time + i_history string history comments + i_limtime int time when min,max last updated + i_maxpixval real maximum pixel value + i_minpixval real minimum pixel value + i_mtime int time of last modify + i_naxis int number of axes (dimensionality) + i_naxis[1-7] int length of each axis + i_pixfile string pathname of pixel storage file + i_pixtype int pixel datatype code + i_title string title string +.fi +.ke + + +The standard header field names have an "i_" prefix to reduce the possibility +of a name collision with a user field name, and to distinguish the two classes +of parameters in templates. The prefix may be omitted provided the simple +name is unique. + + +2.2 Field name template + + The form of the field name list or template parameter \fIfields\fR is +equivalent to that of a filename template except that "@listfile" is not +supported, and of course the template is expanded upon the field name list +of an image, rather than upon a directory. Abbreviations are not permitted +in field names and case is not significant. Case is ignored in this context +due to the present internal storage format for the user parameters (FITS), +which also limits the length of a user field name to 8 characters. + + +2.3 Value expression + + The \fIvalue\fR parameter is a string type parameter. If the first +character in the string is a left parenthesis the string is interpreted as +an algebraic expression wherein the operands may be constants, image header +variables (field names), special variables (defined below), or calls to +intrinsic functions. The expression syntax is equivalent to that used in +the CL and SPP languages. If the value string is not parenthesized it is +assumed to be a string constant. The \fIvalue\fR string will often contain +blanks, quotes, parenthesis, etc., and hence must usually be quoted to avoid +interpretation by the CL rather than by the header editor. + +For example, the command + + cl> hedit m74 title "title // ';ss'" + +would change the title to the literal string constant "title // ';ss'", +whereas the command + + cl> hedit m74 title "(title // ';ss')" + +would concatenate the string ";ss" to the old title string. We require +parenthesis for expression evaluation to avoid the need to doubly quote +simple string constant values, which would be even more confusing for the +user than using parenthesis. For example, if expressions did not have to +be parenthesized, the first example in the basic usage section would have +to be entered as shown below. + + cl> hedit m74 title '"sky flat"' # invalid command + +Expression evaluation for \fIhedit\fR, \fIhselect\fR, and similar tasks +is carried out internally by the FMTIO library routine \fBevexpr\fR. +For completeness minimal documentation is given here, but the documentation +for \fIevexpr\fR itself should be consulted if additional detail is required +or if problems occur. + + +2.3.1 operators + + The following operators are recognized in value expressions. With the +exception of the operators "?", "?=", and "@", the operator set is equivalent +to that available in the CL and SPP languages. + + +.nf + + - * / arithmetic operators + ** exponentiation + // string concatenation + ! - boolean not, unary negation + < <= > >= order comparison (works for strings) + == != && || equals, not equals, and, or + ?= string equals pattern + ? : conditional expression + @ reference a variable +.fi + + +The operators "==", "&&", and "||" may be abbreviated as "=", "&", and "|" +if desired. The ?= operator performs pattern matching upon strings. +For example, the boolean expression shown below will be true whenever the +field "title" contains the substring "sky". + + (title ?= '*sky*') + +The conditional expression operator '?', which is patterned after a similar +operator in C, is used to make IF ELSE like decisions within an expression. +The syntax is as follows: + + '?' ':' + +e.g., the expression + + ((a > b) ? 1 : 0) + +has the value 1 if A is greater than B, and 0 otherwise. The datatypes +of the true and false expressions need not be the same, unlike a compiled +language. Note that if the parenthesis are omitted ambiguous forms of +the expression are possible, e.g.: + + (a > b) ? 1 : a + 1 + +could be interpreted either as + + ((a > b) ? 1 : a) + 1 +or as + (a > b) ? 1 : (a + 1) + +If the parenthesis are omitted the latter interpretation is assumed. + +The operator @ must be used to dereference variables that have names with +funny (non-alphanumeric) characters in them, forcing the variable name to +be given as a string constant. For example, the value of the expression + + @"co-flag" + +is the value of the variable "co-flag". If the variable were referenced +directly by name the "-" would be interpreted as the subtraction operator, +causing an unknown variable reference (e.g., to "co"). +The operand following the @ may be any string valued expression. +The @ operator is right associative, hence the construct "@@param" is the +value of the parameter named by the value of the parameter "param". + +An expression may contain operands of datatypes bool, int, real, and string. +Mixed mode expressions are permitted with automatic type coercion. Most type +coercions from boolean or string to other datatypes are illegal. The boolean +constants "yes" and "no" are predefined and may be used within expressions. + + +2.3.2 intrinsic functions + + A number of standard intrinsic functions are recognized within expressions. +The set of functions currently supported is shown below. + + +.nf + abs acos asin atan atan2 bool cos + exp int log log10 max min mod + nint real sin sqrt str tan +.fi + + +The trigonometric functions operate in units of degrees rather than radians. +The \fImin\fR and \fImax\fR functions may have any number of arguments up +to a maximum of sixteen or so (configurable). The arguments need not all +be of the same datatype. + +A function call may take either of the following forms: + +.nf + '(' arglist ')' +or + '(' arglist ')' +.fi + +The first form is the conventional form found in all programming languages. +The second permits the generation of function names by string valued +expressions and might be useful on rare occasions. + + +2.3.3 special operands + + As noted earlier, expression operands may be constants, variables (header +fields), function calls, or references to any of the special variables. +The following special variables are recognized within expressions: + + +.nf + . A string constant, used to flag printing + $ The value of the "current field" + $F The name of the "current field" + $I The name of the "current image" + $T The current clock time (an integer value) +.fi + + +These builtin variables are especially useful for constructing context +dependent expressions. For example, the value of a field may be incremented +by 100 by assigning it the value "$ + 100". + +.ih +EXAMPLES +1. Globally edit the database "n1", setting the value of the string parameter +"obs" to "sky" if "s-flag" is 1, to "obj" otherwise. + + cl> hedit n1.* obs '(@"s-flag" == 1 ? "sky" : "obj")' + +2. Globally edit the same database, replacing the value of the parameter +"variance" by the square root of the original value. + + cl> hedit n1.* var '(sqrt(var))' + +3. Replace the values of the fields A and B by the absolute value of the +original value: + + cl> hedit n1.* a,b '(abs($))' + +.ih +BUGS +The internal storage format is currently FITS card image, hence field names +are limited to 8 characters with no case sensitivity. String values are +limited to 63 characters. There is an upper limit on the number of fields +in a header but it is quite large - assume it is 1024 or so. Global operations +on databases are currently quite slow because the individual records (image +headers) are stored in separate files. + +A task is needed which would take the audit trail produced by the \fIshow\fR +option and use it to undo an edit. +.ih +SEE ALSO +hselect, imgets, imheader +.endhelp diff --git a/pkg/images/imutil/doc/hselect.hlp b/pkg/images/imutil/doc/hselect.hlp new file mode 100644 index 00000000..d94f240b --- /dev/null +++ b/pkg/images/imutil/doc/hselect.hlp @@ -0,0 +1,103 @@ +.help hselect May85 images.imutil +.ih +NAME +hselect - extract keyword values from images satisfying a selection expression +.ih +USAGE +hselect images fields expr +.ih +PARAMETERS +.ls images +Images forming the set from which selected images are to be drawn. +.le +.ls fields +Comma separated list of keywords or keyword patterns to be extracted +from each selected image. The list elements are matched against the +set of keywords in the header except for those beginning with "$" which +are special values or explicit checks for keywords that might be missing. +.le +.ls expr +The boolean expression to be used as the selection criteria. The expression +is evaluated independently for each image. +.le +.ls missing = "INDEF" +Output value for missing keywords. Note that this will only occur when the +fields are specified with leading "$". +.le +.ih +DESCRIPTION +The function of \fIhselect\fR is to extract keyword values from a subset +of images satisfying a boolean selection expression. The resultant table +of keyword values is output in list form, suitable for further analysis +or for use to generate a list of images to be processed by another task. + +The form of the boolean expression \fIexpr\fR is fully documented in the +manual page for the \fIhedit\fR task. In the case of \fIhselect\fR task, +however, the expression need not be parenthesized to be evaluated as an +expression. + +The keywords whose values are to be output are specified by the \fIfields\fR +parameter. This is a comma delimited list of keywords and patterns. The +keywords and patterns are matched against the set of keywords in the image. +Of particular importance is that explicit keywords, that is without any +wildcard, are matched against the header and so if the keyword is not in the +header then the keyword value is not output. If one wants to explicitly +output a place holder for a missing keyword use a leading $; e.g. $mykey. +If the keyword is absent then the value given by the \fImissing\fR +parameter will be output. This is useful when scanning the output. + +In addition to escaping the keyword matching, the leading $ character is +also used to select special values such as "$I" for the name of the current +image. See \fBhedit\fR for more on the special values and pattern syntax. +.ih +EXAMPLES +1. Compute the mean exposure time for all the images in a database. Note that +the argument "yes" is a trivial case of a general boolean expression and +hence need not be quoted. + + cl> hselect n1.* exp yes | average + +2. Print the name, length of axes 1 and 2, and title of all two dimensional +images in a database. + + +.nf + cl> hselect n1.* $I,naxis[12],title 'naxis == 2' + n1.0001 512 512 quartz + n1.0002 512 512 "dome flat" + n1.0005 384 800 "ngc 3127 at 45 degrees" + cl> +.fi + + +3. Produce an image name list for use to drive another task. The selection +criterion is all images for which the value of the parameter "q-flag" +has the value 1. Note carefully the use of quotes. If the @ operator +is unfamiliar read the manual page for \fIhedit\fR. + + cl> hselect n1.* $I '@"q-flag" == 1' > imlist + +If the parameter "q-flag" were instead named "qflag", the following +simpler expression would suffice. + + cl> hselect n1.* $I 'qflag == 1' > imlist + +4. Scan a set of keyword and allow for missing keywords. + +.nf + cl> hselect pix $I,$exptime,$airmass yes missing=INDEF | + >>> scan (s1, x, y) +.fi + +Note that when checking for missing values the missing value must be +of the appropriate type or else you need to use string variables or +nscan to check. The default missing value is "INDEF" which can be +scanned into both string and numerical variables. +.ih +BUGS +Since individual image headers are currently stored as separate files, +selection from a large database is quite slow. +.ih +SEE ALSO +hedit, imgets, imheader +.endhelp diff --git a/pkg/images/imutil/doc/imarith.hlp b/pkg/images/imutil/doc/imarith.hlp new file mode 100644 index 00000000..00c913e8 --- /dev/null +++ b/pkg/images/imutil/doc/imarith.hlp @@ -0,0 +1,218 @@ +.help imarith Sep86 images.imutil +.ih +NAME +imarith -- binary image arithmetic +.ih +USAGE +imarith operand1 op operand2 result +.ih +PARAMETERS +.ls operand1, operand2 +Lists of images and constants to be used as operands. +Image templates and image sections are allowed. +.le +.ls op +Operator to be applied to the operands. The allowed operators +are "+", "-", "*", "/", "min", and "max". +.le +.ls result +List of resultant images. +.le +.ls title = "" +Title for the resultant images. If null ("") then the title is taken +from operand1 if operand1 is an image or from operand2 otherwise. +.le +.ls divzero = 0. +Replacement value for division by zero. When the denominator is zero +or nearly zero the result is replaced by this value. +.le +.ls hparams = "" +List of header parameters to be operated upon. This is primarily +used for adding exposure times when adding images. +.le +.ls pixtype = "", calctype = "" +Pixel datatype for the resultant image and the internal calculation datatype. +The choices are given below. They may be abbreviated to one character. +.ls "" +\fICalctype\fR defaults to the highest precedence operand datatype. If the +highest precedence datatype is an integer type and the operation is +division then the calculation type will be "real". If the highest +precedence operand is type "ushort", \fIcalctype\fR will default to +"long". \fIPixtype\fR defaults to \fIcalctype\fR. Users who want type +"ushort" images on output will need to set \fIpixtype\fR to "ushort" +explicitly. +.le +.ls "1", "2" +The pixel datatype of the first or second operand. +.le +.ls "short", "ushort", "integer", "long", "real", "double" +Allowed IRAF pixel datatypes. +.le +.le +.ls verbose = no +Print the operator, operands, calculation datatype, and the resultant image +name, title, and pixel datatype. +.le +.ls noact = no +Like the verbose option but the operations are not actually performed. +.le +.ih +DESCRIPTION +Binary image arithmetic is performed of the form: + + operand1 op operand2 = result + +where the operators are addition, subtraction, multiplication, +division, and minimum and maximum. The division operator checks for +nearly zero denominators and replaces the ratio by the value specified +by the parameter \fIdivzero\fR. The operands are lists of images and +numerical constants and the result is a list of images. The number of +elements in an operand list must either be one or equal the number of +elements in the resultant list. If the number of elements is one then +it is used for each resultant image. If the number is equal to the +number of resultant images then the elements in the operand list are +matched with the elements in the resultant list. The only limitation +on the combination of images and constants in the operand lists is that +both operands for a given resultant image may not be constants. The +resultant images may have the same name as one of the operand images in +which case a temporary image is created and after the operation is +successfully completed the image to be replaced is overwritten by the +temporary image. + +If both operands are images the lengths of each axis for the common +dimensions must be the same though the dimensions need not be the +same. The resultant image header will be a copy of the operand image +with the greater dimension. If the dimensions are the same then image +header for the resultant image is copied from operand1. The title of +the resultant image may be changed using the parameter \fItitle\fR. +The pixel datatype for the resultant image may be set using the +parameter \fIpixtype\fR. If no pixel datatype is specified then the +pixel datatype defaults to the calculation datatype given by the +parameter \fIcalctype\fR. The calculation datatype defaults to the +highest precedence datatype of the operand images or constants except +that a division operation will default to real for integer images. +The precedence of the datatypes, highest first, is double, +real, long, integer, and short. The datatype of a constant operand is +either short integer or real. A real constant has a decimal point. + +Arithmetic on images of unequal dimensions implies that the operation +is repeated for each element of the higher dimensions. For example +subtracting a two dimensional image from a three dimensional image +consists of subtracting the two dimensional image from each band of the +three dimensional image. This works for any combination of image +dimensions. As an extreme example dividing a seven dimensional image +by a one dimension image consists of dividing each line of each plane +of each band ... by the one dimensional image. + +There are two points to emphasize when using images of unequal +dimensions. First, a one dimensional image operates on a line +of a two or higher dimension image. To apply a one dimensional image +to the columns of a higher dimensional image increase the image +dimensionality with \fBimstack\fR, transpose the resultant image, +and then replicate the columns with \fBblkrep\fR (see the EXAMPLE +section). The second point of confusion is that an image with a +size given by \fBimheader\fR of [20,1] is a two dimensional image +while an image with size of [20] is a one dimensional image. To +reduce the dimensionality of an image use \fBimcopy\fR. + +In addition to operating on the image pixels the image header parameters +specified by the list \fIhparams\fR are also operated upon. The operation +is the same as performed on the pixels and the values are either the +values associated with named header parameters or the operand constant +values. The primary purpose of this feature is to add exposure times +when adding images. + +The verbose option is used to record the image arithmetic. The output +consists of the operator, the operand image names, the resultant image +name and pixel datatype, and the calculation datatype. +.ih +EXAMPLES +1. To add two images and the exposure times: + +.nf + cl> imarith ccd1 + ccd2 sum + >>> hparams="itime,otime,ttime,exposure" +.fi + +2. To subtract a constant from an image and replace input image by the +subtracted image: + + cl> imarith m31 - 223.2 m31 + +Note that the final pixel datatype and the calculation datatype will be at +least of type real because the constant operand is real. + +3. To scale two exposures, divide one by the other, and extract the central +portion: + +.nf + cl> imarith exp1[10:90,10:90] * 1.2 temp1 + cl> imarith exp2[10:90,10:90] * 0.9 temp2 + cl> imarith temp1 / temp2 final title='Ratio of exp1 and exp 2' + cl> imdelete temp1,temp2 +.fi + +Note that in this example the images temp1, temp2, and final will be +of real pixel datatype (or double if either exp1 or exp2 are of pixel +datatype double) because the numerical constants are real numbers. + +4. To divide two images of arbitrary pixel datatype using real arithmetic +and create a short pixel datatype resultant image: + +.nf + cl> imarith image1 / image2 image3 pixtype=real \ + >>> calctype=short title="Ratio of image1 and image2" +.fi + +5. To divide several images by calibration image using the image pixel type of +the numerator images to determine the pixel type of the calibration images +and the calculation arithmetic type: + +.nf + cl> imarith image1,image2,image3 / calibration \ + >>> image1a,image2a,image3a pixtype=1 calctype=1 +.fi + +The same operation can be done in place with image template expansion by: + +.nf + cl> imarith image* / calibration image* pixtype=1 calctype=1 +.fi + +6. To subtract a two dimensional bias from stacked observations (multiple +two dimensional observations stacked to form a three dimensional image): + + cl> imarith obs* - bias obs*//b + +Note that the output observations obs101b, ..., will be three dimensional. + +7. To divide a 50 x 50 image by the average column: + +.nf + cl> blkavg img avcol 50 1 + cl> blkrep avcol avcol 50 1 + cl> imarith img / avcol flat +.fi + +8. To subtract a one dimensional image from the lines of a two dimensional +image: + + cl> imarith im2d - im1d diff + +9. To subtract a one dimensional image from the columns of a two dimensional +image: + +.nf + cl> imstack im1d imcol + cl> imtranspose imcol imcol + cl> blkrep imcol imcol 100 1 + cl> imarith im2d - imcol diff +.fi + +Note the need to make a two dimensional image with each column +replicated since a one dimensional image will operate on the lines +of a two dimensional image. +.ih +SEE ALSO +blkrep, imdivide, imfunction, imstack, imtranspose +.endhelp diff --git a/pkg/images/imutil/doc/imcopy.hlp b/pkg/images/imutil/doc/imcopy.hlp new file mode 100644 index 00000000..1128c587 --- /dev/null +++ b/pkg/images/imutil/doc/imcopy.hlp @@ -0,0 +1,91 @@ +.help imcopy Oct84 images.imutil +.ih +NAME +imcopy -- copy images +.ih +USAGE +imcopy input output +.ih +PARAMETERS +.ls input +Images to be copied. +.le +.ls output +Output images or directory. +.le +.ls verbose = yes +Print each operation as it takes place? +.le +.ih +DESCRIPTION +Each of the input images, which may be given as a general image template +including sections, is copied to the corresponding output image list, +which may also be given as an image template, or the output directory. +If the output is a list of images then the number of input images must be +equal to the number of output images and the input and output images are paired +in order. If the output image name exists and contains a section then the +input image (provided it is the same size as the section) will be copied +into that section of the input image. If the output image name does not +have a section specification and if it is the same as the input image name +then the input image is copied to a temporary file which replaces the input +image when the copy is successfully concluded. Note that these are the only +cases where clobber checking is bypassed; that is, if an output image name +is not equal to the input image name or a subsection of an existing image +and the file already exists then a clobber error will occur if +clobber checking is in effect. + +The verbose options prints for each copy lines of the form: +.nf + +input image -> output image +.fi +.ih +EXAMPLES +1. For a simple copy of an image: + + cl> imcopy image imagecopy + +2. To copy a portion of an image: + + cl> imcopy image[10:20,*] subimage + +3. To copy several images: + + cl> imcopy image1,image2,frame10 a,b,c + +4. To trim an image: + + cl> imcopy image[10:20,*] image + +In the above example the specified section of the input image replaces the +original input image. To trim several images using an image template: + + cl> imcopy frame*[1:512,1:512] frame* + +In this example all images beginning with "frame" are trimmed to 512 x 512. + +5. To copy a set of images to a new directory: + +.nf + cl> imcopy image* directory + or + cl> imcopy image* directory$ + or + cl> imcopy image* osdirectory +.fi + +where "osdirectory" is an operating system directory name (i.e. /user/me +in UNIX). + +6. To copy a section of an image in an already existing image of + sufficient size to contain the input section. + +.nf + cl> imcopy image[1:512,1:512] outimage[257:768,257:768] +.fi + +.ih +BUGS +The distinction between copying to a section of an existing image +and overwriting a input image is rather inobvious. +.endhelp diff --git a/pkg/images/imutil/doc/imdelete.hlp b/pkg/images/imutil/doc/imdelete.hlp new file mode 100644 index 00000000..54d926fe --- /dev/null +++ b/pkg/images/imutil/doc/imdelete.hlp @@ -0,0 +1,55 @@ +.help imdelete Dec85 images.imutil +.ih +NAME +imdelete -- delete a list of images +.ih +USAGE +imdelete images +.ih +PARAMETERS +.ls images +List of images to be deleted. +.le +.ls go_ahead +Delete the image? +.le +.ls verify = no +Verify the delete operation for each image. +.le +.ls default_action = yes +The default action for the verify query. +.le +.ih +DESCRIPTION +IMDELETE takes as input a list of IRAF images specified by \fIimages\fR and +deletes both the header and pixel files. In \fIverify\fR mode IMDELETE +queries the user for the appropriate action to be taken for each IRAF image. + +If the \fIimages\fR parameter is a URL, it will be accessed and put into +the file cache, then immediately deleted. To simply remove a file from +the cache, use the \fIfcache\fR command instead. +.ih +EXAMPLES +1. Delete a list of images + +.nf + cl> imdelete fits* +.fi + +2. Delete a list of images using verify + +.nf + cl> imdel fits* ver+ + cl> Delete file \fI'fits1'\fR ? (yes): yes + cl> Delete file \fI'fits2'\fR ? (yes): yes + cl> Delete file \fI'fits3'\fR ? (yes): yes +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imcopy, fcache +.endhelp diff --git a/pkg/images/imutil/doc/imdivide.hlp b/pkg/images/imutil/doc/imdivide.hlp new file mode 100644 index 00000000..2f104029 --- /dev/null +++ b/pkg/images/imutil/doc/imdivide.hlp @@ -0,0 +1,65 @@ +.help imdivide Sep86 images.imutil +.ih +NAME +imdivide -- image division with zero checking and rescaling +.ih +USAGE +imdivide numerator denominator resultant +.ih +PARAMETERS +.ls numerator +Numerator image. +.le +.ls denominator +Denominator image. +.le +.ls resultant +Resultant image. This image will be of datatype real. +.le +.ls title = '*' +Title for resultant image. The special character '*' defaults the title +to that of the numerator image. +.le +.ls constant = 0 +The constant value for the zero division constant option. +.le +.ls rescale = norescale +After the image division the resultant image may be rescaled with the following +options: +.ls norescale +Do not rescale the resultant image. +.le +.ls mean +Scale the resultant image to the specified mean value. +.le +.ls numerator +Scale the resultant image to have the same mean value as the numerator image. +.le +.le +.ls mean = 1 +The mean value used rescale the resultant image under 'mean' option of +\fIrescale\fR. +.le +.ls verbose = no +Print the means of each image? +.le +.ih +DESCRIPTION +The \fInumerator\fR image is divided by the \fIdenominator\fR image to +form the \fIresultant\fR image. The division is checked for division by +zero and replaces the result with the value of the parameter \fIconstant\fR. +After the division the resultant image may be rescaled. +The rescaling option is selected with \fIrescale\fR. The options are +not to rescale, rescale to the specified \fImean\fR value, and rescale to +the mean of the numerator. The means of the three images are calculated +and may be printed with the verbose option. +.ih +EXAMPLES +1. To divide a object image by a flat field and then rescale the division +back to the mean of the object image: + + cl> imdivide object image final rescale=numerator +.ih +SEE ALSO +imarith +.endhelp diff --git a/pkg/images/imutil/doc/imexpr.hlp b/pkg/images/imutil/doc/imexpr.hlp new file mode 100644 index 00000000..76886d95 --- /dev/null +++ b/pkg/images/imutil/doc/imexpr.hlp @@ -0,0 +1,447 @@ +.help imexpr Dec01 images.imutil +.ih +NAME +imexpr -- General image expression evaluator +.ih +USAGE +imexpr expr output [a b c ...] +.ih +PARAMETERS +.ls expr +The expression to be evaluated. This may be the actual expression, or the +string "@file" in which case the expression is taken from the named file. +The input operands (i.e., numeric constants, images, or image header +parameters) are referred to in the expression symbolically using the letters +"a" through "z". +.le +.ls output +The output image. A section may be given to write into a section of an +existing image. +.le +.ls a - z +The input operands referenced by the expression. The value of an operand +may be an image name or section, a numeric constant, or a reference to an +image header parameter of the form \fIoperand.param\fR, where \fIoperand\fR +is one of the other input operands "a" through "z", corresponding to an input +image (for example, "a.itime" is the parameter "itime" from the image +assigned to operand "a"). An example of an input image operand is +"a=dev$pix". +.le +.ls dims = "auto" +The dimensions of the output image. If the special value \fIauto\fR is +given the output image dimensions are computed based on the input operands +and the expression being evaluated. Otherwise the value is a list of axis +lengths, e.g., "512,512". +.le +.ls intype = "int" +The minimum datatype for an input image operand. If the special value +\fIauto\fR is given the operand type will be the same as the pixel type of +the image. Otherwise one of the values "short", "int", "long", "real", +or "double" should be given. The program will promote the type of the +input operand to the type specified if the actual type is less precise +than the value of \fIintype\fR, otherwise the type of the input operand +is not changed. For example, if \fIintype\fR is "int" (the default), +short integer input operands will be promoted to integer but int, long, +real or double operands will be unaffected. Setting \fIintype\fR to real +will force the expression to be evaluated in floating point. +.le +.ls outtype = "auto" +The pixel type of the output image. If set to the special value \fIauto\fR +the output image will be the same type as the expression being evaluated. +If set to \fIref\fR the output image will have the same type as the +"reference" input image (see below), regardless of the expression type. +If an explicit type is specified such as "short", "ushort", "int", "real", +an image of the indicated type will be created. +.le +.ls refim = "auto" +The reference image to be used to pass the WCS and other image header +attributes to the output image. If set to \fIauto\fR the program will +compute the best reference image, which is the first input image +with the highest number of dimensions. To force a particular input image +to be the reference image the value should be set to the name of an input +operand ("a", "b", etc.). The named operand must refer to an image. +.le +.ls bwidth = 0 +The boundary width in pixels for boundary extension. Boundary extension +is enabled by setting this value to a positive nonzero value. Boundary +extension is needed when an input image section references out of bounds. +.le +.ls btype = "nearest" +The type of boundary extension, chosen from the list "constant", "nearest", +"reflect", "wrap", or "project". +.le +.ls bpixval = 0. +The boundary pixel value if \fIbtype\fR="constant". +.le +.ls rangecheck = yes +If range checking is enabled then the program will check for illegal +operations such as divide by zero or the square root or logarithm of a +negative value, substituting a constant value (zero) if such an operation +is detected. This may be necessary to avoid aborting the entire operation +because of a few bad pixels in an image. A conditional expression may be +used to detect such pixels and perform any special processing. +.le +.ls verbose = yes +Enable or disable informative messages. If enabled, the program will echo +the expression to be evaluated after all expansions have been performed, +and percent-done messages will be printed as the expression is evaluated. +.le +.ls exprdb = "" +The file name of an optional expression database. An expression database +may be used to define symbolic constants or a library of custom function +macros. +.le +.ih +DESCRIPTION +\fIimexpr\fR evaluates an image expression and writes the result to the +output image. Images may be any dimension or size and any datatype except +complex (complex images may be read but only the real part will be used). + +If the input images are not all the same size the computation will be +performed over the largest area which is common to all images. If the +images are not all the same dimension the lesser dimension operands will be +iteratively combined with the higher dimension ones. For example, when +both a one and two dimensional image are used in the same expression, +the vector (one dimensional image) will be applied to all lines of the +two dimensional image. + +Evaluation of the image expression is carried out one line at a time. This +is efficient and permits operations on arbitrarily large images without +using excessive memory, but does not allow 2D or higher operations to be +performed within the expression (e.g., transpose). The entire expression is +evaluated once for each line of the output image. + + +\fBOperands\fR + +Input operands are represented symbolically in the input expression using +the symbols "a" through "z", corresponding to \fIimexpr\fR task parameters. +Use of symbolic operands allows the same expression to be used with different +data sets, simplifies the expression syntax, and allows a single input image +to be used several places in the same expression. + +Three classes of input operands are recognized: images, image parameters, and +numeric constants. + +.nf + dev$pix[*,55] image operand + a.itime image parameter + 1.2345 numeric constant +.fi + +Since the input operands are CL parameters they may be set on the command +line, or entered in response to parameter prompts when the task executes and +evaluates the input expression. For example, + +.nf + cl> imexpr "a - a/b" pix + operand a: dev$pix[*,55] + operand b: a.itime +.fi + +would evaluate the expression shown, storing the result in the output image +"pix". + +Operands may also be specified directly in the expression, with the +exception of image operands. For example, + + cl> imexpr "a - a / a.itime" + +is equivalent to the earlier example. + +If the input operand is not a simple identifier (a simple name like "itime" +containing only alphanumeric characters, underscore, ".", or "$") then it +is necessary to quote the operand name and precede it with an "@", e.g., + + cl> imexpr 'a - a / @"a.i-time"' + +Finally, there is a special builtin type of operand used to represent the +image pixel coordinates in an image expression. These operands have the +special reserved names "I", "J", "K", etc., up to the dimensions of the +output image. The names must be upper case to avoid confusion to with the +input operands "i", "j", "k" and so on. + +.nf + I X coordinate of pixel (column) + J Y coordinate of pixel (line) + K Z coordinate of pixel (band) +.fi + +An example of the use of the pixel coordinate operands is the generation of +multidimensional analytic functions. + + +\fBOperators\fR + +The expression syntax implemented by \fIimexpr\fR provides the following +set of operators: + +.nf + ( expr ) grouping + + - * / arithmetic + ** exponentiation + // concatenate + expr ? expr1 : expr2 conditional expression + @ "name" get operand + + && logical and + || logical or + ! logical not + < less than + <= less than or equal + > greater than + >= greater than or equal + == equals + != not equals + ?= substring equals + + & bitwise and + | bitwise or + ^ bitwise exclusive or + ~ bitwise not (complement) +.fi + +The conditional expression has the value \fIexpr1\fR if \fIexpr\fR is true, +and \fIexpr2\fR otherwise. Since the expression is evaluated at every pixel +this permits pixel-dependent operations such as checking for special pixel +values, or selection of elements from either of two vectors. For example, +the command + + (a < 0) ? 555 : b / a + +has the constant value 555 if "a" is less than zero, and "b / a" otherwise. +Conditional expressions are general expressions and may be nested or used +anywhere an expression is permitted. + +The concatenation operator applies to all types of data, not just strings. +Concatenating two vectors results in a vector the combined length of the +two input vectors. + +The substring equals operator "?=", used for string comparisons, is like +"==" but checks for the presence of a substring, rather than exact equality +of the two strings. + + +\fBFunctions\fR + +Where it makes sense all intrinsic functions support all datatypes, with +some restrictions on \fIbool\fR and \fIchar\fR. Arguments may be scalars or +vectors and scalar and vector arguments may be mixed in the same function +call. Arguments are automatically type converted upon input as necessary. +Some functions support a variable number of arguments and the details of +the the operation to be performed may depend upon how many arguments are +given. + +Functions which operate upon vectors are applied to the \fIlines\fR of an +image. When applied to an image of dimension two or greater, these +functions are evaluated separately for every line of the multidimensional +image. + +Standard Intrinsic Functions + +.nf + abs (a) absolute value + max (a, b, ...) maximum value + min (a, b, ...) minimum value + mod (a, b) modulus + sqrt (a) square root +.fi + +Mathematical or trigonometric functions + +.nf + acos (a) arc cosine + asin (a) arc sine + atan (a [,b]) arc tangent + atan2 (a [,b]) arc tangent + cos (a) cosine + cosh (a) hyperbolic cosine + exp (a) exponential + log (a) natural logarithm + log10 (a) logarithm base 10 + sin (a) sine + sinh (a) hyperbolic sine + tan (a) tangent + tanh (a) hyperbolic tangent +.fi + +The trigonometric functions operate in units of radians. The \fIdeg\fR and +\fIrad\fR intrinsic functions (see below) can be used to convert to and from +degrees if desired. + +Type conversion functions + +.nf + bool (a) coerce to boolean + short (a) coerce to short + int (a) truncate to integer + nint (a) nearest integer + long (a) coerce to long (same as int) + real (a) coerce to real + double (a) coerce to double + str (a) coerce to string +.fi + +The numeric type conversion functions will convert a string to a number if +called with a character argument. The \fIstr\fR function will convert any +number to a string. + +Projection functions + +.nf + len (a) length of a vector + hiv (a) high value of a vector + lov (a) low value of a vector + mean (a [, ksigma]) mean of a vector + median (a) median of a vector + stddev (a [, ksigma]) standard deviation + sum (a) sum of a vector +.fi + +The projection functions take a vector as input and return a scalar value as +output. The functions \fImean\fR and \fIstddev\fR, used to compute the mean +and standard deviation of a vector, allow an optional second argument which +if given causes a K-sigma rejection to be performed. + +Miscellaneous functions + +.nf + deg (a) radians to degrees + rad (a) degrees to radians + median (a, b, c [, d [, e]]) vector median of 3-5 vectors + repl (a, n) replicate + sort (a) sort a vector + shift (a, npix) shift a vector +.fi + +The \fImedian\fR function shown here computes the vector median of several +input vectors, unlike the projection median which computes the median value +of a vector sample. \fIsort\fR sorts a vector, returning the sorted vector +as output (this can be useful for studying the statistics of a sample). +\fIshift\fR applies an integral pixel shift to a vector, wrapping around at +the endpoints. A positive shift shifts data features to the right (higher +indices). + +The \fIrepl\fR (replicate) function replicates a data element, returning a +vector of length (n * len(a)) as output. For example, this can be used to +create a dummy data array or image by replicating a constant value. + + +\fBThe Expression Database\fR + +The \fIimexpr\fR expression database provides a macro facility which can be +used to create custom libraries of functions for specific applications. A +simple example follows. + +.nf + # Sample IMEXPR expression database file. + + # Constants. + SQRTOF2= 1.4142135623730950488 + BASE_E= 2.7182818284590452353 + PI= 3.1415926535897932385 + GAMMA= .57721566490153286061 # Euler's constant + + # Functions. + div10(a) ((a) / 10) + divz(a,b) ((abs(b) < .000001) ? 0 : a / b) + + div(a,b) (div10(b) / a) + sinx (cos(I / 30.0)) + sinxy(a,b) (cos (I / a) + cos (J / b)) +.fi + +The complete syntax of a macro entry is as follows: + + ['(' arg-list ')'][':'|'='] replacement-text + +The replacement text may appear on the same line as the macro name or may +start on the next line, and may extend over multiple input lines if +necessary. If so, continuation lines must be indented. The first line +with no whitespace at the beginning of the line terminates the macro. +Macro functions may be nested. Macro functions are indistinguishable from +intrinsic functions in expressions. + + +\fBIMEXPR and Pixel Masks\fR + +Although \fIimexpr\fR has no special support for pixel masks, it was +designed to work with masks and it is important to realize how these can be +used. IRAF image i/o includes support for a special type of image, the +pixel mask or ".pl" type image. Pixel masks are used for things such as +region identification in images - any arbitrary region of an image can be +assigned a constant value in a mask to mark the region. Masks can then be +used during image analysis to identify the subset of image pixels to be +used. An image mask stored as a ".pl" file is stored in compressed form and +is typically only a few kilobytes in size. + +There are many ways to create masks, but in some cases \fIimexpr\fR itself +can be used for this purpose. For example, to create a boolean mask with +\fIimexpr\fR merely evaluate a boolean expression and specify a ".pl" file +as the output image. For example, + + cl> imexpr "a > 800" mask.pl + +will create a boolean mask "mask.pl" which identifies all the pixels in an +image with a value greater than 800. + +An example of the use of masks is the problem of combining portions of two +images to form a new image. + + cl> imexpr "c ? a : b" c=mask.pl + +This example will select pixels from either image A or B to form the output +image, using the mask assigned to operand C to control the selection. +.ih +EXAMPLES +1. Copy an image, changing the datatype to real (there are better ways to +do this of course). + + cl> imexpr a pix2 a=pix outtype=real + +2. Create a new, empty image with all the pixels set to 0. + + cl> imexpr "repl(0,512)" pix dim=512,512 + +3. Create a 1D image containing the sinc function. + + cl> imexpr "I == 10 ? 1.0 : sin(I-10.0)/(I-10)" sinc dim=20 + +4. Create a new image containing a simple test pattern consisting of a 5 +element vector repeated 100 times across each image line. + + cl> imexpr "repl((9 // 3 // 3 // 11 // 11), 100)" patt dim=500,500 + +5. Subtract the median value from each line of an image. + + cl> imexpr "a - median(a)" medimage + +6. Compute the HIV (low value) projection of an image. The result is a +transposed 1D image. + + cl> imexpr "hiv(a)" hvector + +7. Swap the left and right halves of an image. + +.nf + cl> imexpr "a // b" pix swapimage + operand a: dev$pix[256:512,*] + operand b: dev$pix[1:255,*] +.fi + +8. Create a circular mask of a given radius about a user-defined center. + +.nf + cl> type expr + (sqrt((I-b)**2 + (J-c)**2) <= d) + cl> imexpr @expr mask.pl b=256 c=256 d=100 dims=512,512 +.fi + +.ih +BUGS +The input and output images cannot be the same. +No support for type complex yet, or operations like the fourier transform. +.ih +SEE ALSO +imarith, imfunction, imcombine +.endhelp diff --git a/pkg/images/imutil/doc/imfunction.hlp b/pkg/images/imutil/doc/imfunction.hlp new file mode 100644 index 00000000..6cdef58e --- /dev/null +++ b/pkg/images/imutil/doc/imfunction.hlp @@ -0,0 +1,130 @@ +.help imfunction Aug91 images.imutil +.ih +NAME +imfunction -- Apply a function to the image pixel values +.ih +USAGE +imfunction input output function +.ih +PARAMETERS +.ls input +The input image list. +.le +.ls output +Output image list. The number of output images must match the number of +input images. If the output image list equals the input image list +the input images are overwritten. +.le +.ls function +Function to be applied to the input pixels. The options are: +.ls log10 +Take the logarithm to base 10 of an image. Negative and zero-valued +pixels will be assigned the value -MAX_EXPONENT. +.le +.ls alog10 +Taken the antilogarithm to base 10 of the image. Positive out-of-bounds +pixel values will be assigned the value MAX_REAL, negative out-of-bounds +pixel values will be assigned the value 0.0. +.le +.ls ln +Take the natural logarithm of an image. Negative and zero-valued pixels +will be assigned the value - ln (10.) * MAX_EXPONENT. +.le +.ls aln +Take the antilogarithm to base e of an image. Positive out-of-bounds pixel +values will be assigned the value MAX_REAL, negative out-of-bounds +pixel values will be assigned the value 0.0 +.le +.ls sqrt +Take the square root of an image. Negative pixel values will be assigned +the value 0.0. +.le +.ls square +Take the square of an image. +.le +.ls cbrt +Take the cube root of an image. +.le +.ls cube +Take the cube of an image. +.le +.ls abs +Take the absolute value of an image. +.le +.ls neg +Take the negative of an image. +.le +.ls cos +Take the cosine of an image. +.le +.ls sin +Take the sine of an image. +.le +.ls tan +Take the tangent of an image. +.le +.ls acos +Take the arc-cosine of an image. The output pixels will lie between +0.0 and PI. +.le +.ls asin +Take the arc-sine of an image. The output pixels will lie between -PI/2 +and +PI/2. +.le +.ls atan +Take the arc-tangent of an image. The output pixels will lie between +-PI/2 and +PI/2. +.le +.ls hcos +Take the hyperbolic cosine of an image. Positive or negative +out-of-bounds pixels will be assigned the value MAX_REAL. +.le +.ls hsin +Take the hyperbolic sine of an image. Positive and negative out-of-bounds +pixel values will be assigned the values MAX_REAL and -MAX_REAL respectively. +.le +.ls htan +Take the hyperbolic tangent of an image. +.le +.ls reciprocal +Take the reciprocal of an image. Zero-valued pixels will be assigned +the output value 0.0 +.le +.le +.ls verbose = yes +Print messages about actions taken by the task? +.le + +.ih +DESCRIPTION + +The selected function \fIfunction\fR is applied to the pixel values of all +the input images \fIinput\fR to create the pixel values of the output +images \fIoutput\fR. The number of output images must equal the number of +input images. If the output image name is the same as the input image name +the input image will be overwritten. + +If the input image is type real or double the output image will +be of type real or double respectively. If the input image is type +ushort then the output image will be type real. If the input image is one of +the remaining integer data types, then the output image will be type +real, unless function is "abs" or "neg", in which case the output +data type will be the same as the input data type. + +Values of the machine dependent constants MAX_REAL and MAX_EXPONENT can be +found in the file "hlib$mach.h". + +.ih +EXAMPLES + +1. Take the logarithm of the pixel values of images in1 and in2 and write +the results to out1 and out2. + +.nf + cl> imfunction in1,in2 out1,out2 log10 +.fi + +.ih +SEE ALSO +imarith,imreplace +.endhelp diff --git a/pkg/images/imutil/doc/imgets.hlp b/pkg/images/imutil/doc/imgets.hlp new file mode 100644 index 00000000..12fa2a74 --- /dev/null +++ b/pkg/images/imutil/doc/imgets.hlp @@ -0,0 +1,70 @@ +.help imgets Jan85 images.imutil +.ih +NAME +imgets -- get the value of an image header parameter as a string +.ih +USAGE +imgets image param +.ih +PARAMETERS +.ls image +Name of the image to be accessed. +.le +.ls param +Name of the parameter whose value is to be returned. +.le +.ls value = "" +The value of the parameter, returned as a string. +.le +.ih +DESCRIPTION +The value of the parameter \fIparam\fR of the image \fIimage\fR is returned +as a string in the output parameter \fIvalue\fR. The CL type coercion +functions \fIint\fR and \fIreal\fR may be used to decode the returned +value as an integer or floating point value. Both standard image header +parameters and special application or instrument dependent parameters may be +accessed. If the parameter cannot be found a warning message is printed and +the value "0" is returned. Parameter names are case sensitive. + +The following standard image header parameters may be accessed with +\fBimgets\fR: + +.nf + i_pixtype pixel type (short, real, etc.) + i_naxis number of dimensions + i_naxis[1-7] length of the axes (x=1,y=2) + i_minpixval minimum pixel value or INDEF + i_maxpixval maximum pixel value or INDEF + i_title image title string + i_pixfile pixel storage file name +.fi + +This task is most useful for image parameter access from within CL scripts. +The task \fBimheader\fR is more useful for just looking at the image header +parameters. +.ih +EXAMPLES +1. Fetch the instrument parameter "HA" (hour angle) from the image header of +the image "nite1.1001", and compute and print the hour angle in degrees: + +.ks +.nf + cl> imgets nite1.1001 HA + cl> = real(imgets.value) * 15.0 + 42.79335 +.fi +.ke + +2. Print the number of pixels per line in the same image. + +.ks +.nf + cl> imgets nite1.1001 i_naxis1 + cl> = int(imgets.value) + 1024 +.fi +.ke +.ih +SEE ALSO +imheader, hedit, hselect +.endhelp diff --git a/pkg/images/imutil/doc/imheader.hlp b/pkg/images/imutil/doc/imheader.hlp new file mode 100644 index 00000000..c32feb0a --- /dev/null +++ b/pkg/images/imutil/doc/imheader.hlp @@ -0,0 +1,62 @@ +.help imheader Jun97 images.imutil +.ih +NAME +imheader -- list header parameters for a list of images +.ih +USAGE +imheader [images] +.ih +PARAMETERS +.ls images +List of IRAF images. +.le +.ls imlist = "*.imh,*.fits,*.pl,*.qp,*.hhh" +The default IRAF image name template. +.le +.ls longheader = no +Print verbose image header. +.le +.ls userfields = yes +If longheader is set print the information in the user area. +.le +.ih +DESCRIPTION +IMHEADER prints header information in various formats for the list of IRAF +images specified by \fIimages\fR, or by the default image name template +\fIimlist\fR. If \fIlongheader\fR = no, the image name, +dimensions, pixel type and title are printed. If \fIlongheader\fR = yes, +information on the create and modify dates, image statistics and so forth +are printed. Non-standard IRAF header information can be printed by +setting \fIuserfields\fR = yes. + +.ih +EXAMPLES + +1. Print the header contents of a list of IRAF fits images. + +.nf + cl> imheader *.fits +.fi + +2. Print the header contents of a list of old IRAF format images in verbose +mode. + +.nf + cl> imheader *.imh lo+ +.fi + +3. Print short headers for all IRAF images of all types, e.g. imh, fits etc +in the current directory. + +.nf + cl> imheader +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imgets, hedit, hselect +.endhelp diff --git a/pkg/images/imutil/doc/imhistogram.hlp b/pkg/images/imutil/doc/imhistogram.hlp new file mode 100644 index 00000000..970f07fc --- /dev/null +++ b/pkg/images/imutil/doc/imhistogram.hlp @@ -0,0 +1,111 @@ +.help imhistogram Nov89 images.imutil +.ih +NAME +imhistogram -- print or plot the histogram of an image +.ih +USAGE +imhistogram image +.ih +PARAMETERS +.ls image +The name of the image or image subsection whose histogram is to be calculated. +.le +.ls z1 = INDEF, z2 = INDEF +The minimum and maximum histogram intensity. The image minimum and maximum +pixel values are used by default. +.le +.ls binwidth = INDEF +The resolution of the histogram in counts. If \fIbinwidth\fR is not defined, +the parameter \fInbins\fR determines the histogram resolution. +.le +.ls nbins = 512 +The number of bins in, or resolution of, the histogram. +The \fInbins\fR parameter is overridden if \fIbinwidth\fR is defined. +.le +.ls autoscale = yes +In the case of integer data, automatically adjust \fInbins\fR and +\fIz2\fR to avoid aliasing effects. +.le +.ls top_closed = no +Include z2 in the top bin? Each bin of the histogram is a subinterval +that is half open at the top. \fITop_closed\fR decides whether those +pixels with values equal to z2 are to be counted in the histogram. If +\fBtop_closed\fR is yes, the top bin will be larger than the other bins. +.le +.ls hist_type = "normal" +The type of histogram to plot or list. The choices are "normal", +"cumulative", "difference", or "second_difference". The two +"difference" options are calculated as forward differences, i.e., +diff[n] = hist[n+1] - hist[n]. +.le +.ls listout = no +List instead of plot the histogram? The list is never log scaled. +.le +.ls plot_type = "line" +The plot vector type. The options are "line" and "box". +.le +.ls logy = yes +Use log scaling on the y-axis of the plot? +.le +.ls device = "stdgraph" +The output graphics device. +.le +.ih +DESCRIPTION +\fIimhistogram\fR calculates the histogram of the IRAF image +\fIimage\fR using the parameters \fInbins\fR, \fIz1\fR and \fIz2\fR. +If either \fIz1\fR or \fIz2\fR is undefined the image minimum or +maximum is used. If \fIlistout\fR = no, the histogram is plotted on +the graphics device \fIdevice\fR in the vector mode specified by +\fIplot_type\fR. The plot may be log scaled if \fIlogy\fR = yes (the +default). If \fIlistout\fR = yes, the histogram is listed on the +standard output. + +In addition to producing the "normal" histogram, the task will also +calculate cumulative and marginal (forward difference) histograms +depending on the choice of the \fIhist_type\fR parameter (choices +are: "normal", "cumulative", "difference", and "second_difference"). +The plot will be labeled by the type of histogram as well as the image +name and title and the binning parameters. + +Each bin of the histogram is defined to be half open at the top. This +results in an ambiguity deciding whether those pixels with z=z2 are +included in the topmost bin. This decision is left to the user via the +\fItop_closed\fR parameter. This is usually only important with integer +images and histograms with few bins. +.ih +EXAMPLES +1. Output the histogram of an image to a file. + + cl> imhist M51.imh li+ nbins=100 > fits1.hst + +2. Plot the histogram of another image between the values 0 and 2000. + + cl> imhist M31.imh nbins=100 z1=0. z2=2000. + +3. Ditto, but set the histogram resolution explicitly to avoid +smoothing the histogram. + + cl> imhist M31.imh nbins=100 z1=0 z2=2000 nbins=2001 + +4. Plot the cumulative histogram. This is most useful for images with +fairly flat "normal" histograms. + + cl> imhist R50.imh hist=cum +.ih +BUGS +If the resolution of the histogram (number of bins) is a non-integral multiple +of the intensity resolution of the data (number of possible intensity values), +then \fIaliasing\fR can occur. The effect is to cause periodic zero dropouts +(for an oversampled histogram) or excess-valued bins (for a slightly +undersampled histogram). The \fIautoscaling\fR feature, if enabled, will +adjust the histogram parameters to avoid such aliasing effects for integer +data. This is not possible for floating point data, however, in which case +aliasing is certainly possible and can only be avoided by manually adjusting +the histogram parameters. One should also be aware that \fIsmoothing\fR of +the histogram will occur whenever the data range exceeds the histogram +resolution. +.ih +SEE ALSO +listpixels, plot.graph, proto.mkhistogram +.endhelp diff --git a/pkg/images/imutil/doc/imjoin.hlp b/pkg/images/imutil/doc/imjoin.hlp new file mode 100644 index 00000000..0c5d8245 --- /dev/null +++ b/pkg/images/imutil/doc/imjoin.hlp @@ -0,0 +1,70 @@ +.help imjoin Jan97 images.imutil +.ih +NAME +imjoin -- join images along a specified axis +.ih +USAGE +imjoin input output join_dimension +.ih +PARAMETERS +.ls input +The list of input images to be joined. The input images must have the +same dimensionality and the same size along all dimensions but the join +dimension. +.le +.ls output +The output combined image. +.le +.ls join_dimension +The image dimension along which the input images will be joined. +.le +.ls pixtype = "" +The output image pixel type. The options are in order of increasing +precedence "s" (short), "u" (unsigned short), "i" (integer), +"l" (long integer), "r" (real), "d" (double), and "x" (complex). +If the output image pixel type is not specified, it defaults to highest +precedence input image datatype. +.le +.ls verbose = yes +Print messages about actions taken by the task ? +.le + +.ih +DESCRIPTION + +IMJOIN creates a single output image \fIoutput\fR by joining a list of input +images \fIinput\fR along a specified dimension \fIjoin_dimension\fR. IMJOIN +can be used to create a single long 1-dimensional image from a list of shorter +1-dimensional images, or to piece together a set of 3-dimensional images into +larger 3-dimensional images along either the x, y, or z directions. The input +images must all have the same number of dimensions and the same size along +all dimensions by the join dimension. The output image inherits the +world coordinates system if any of the first input image. + +.ih +EXAMPLES + +.nf +1. Join a list of 1-dimensional spectra into a single long output spectrum. + + cl> imjoin @inlist output 1 + +2. Join three datacubes along the z direction. + + cl> imjoin c1,c2,c3 c123 3 + +.fi + +.ih +TIMINGS + +.ih +BUGS + +On some systems there are limitations on the number of input images that +can be joined in a single execution of IMJOIN. + +.ih +SEE ALSO +imstack, imslice, imtile +.endhelp diff --git a/pkg/images/imutil/doc/imrename.hlp b/pkg/images/imutil/doc/imrename.hlp new file mode 100644 index 00000000..dbba949b --- /dev/null +++ b/pkg/images/imutil/doc/imrename.hlp @@ -0,0 +1,50 @@ +.help imrename Apr89 images.imutil +.ih +NAME +imrename -- rename one or more images +.ih +USAGE +imrename oldnames newnames +.ih +PARAMETERS +.ls oldnames +An image template specifying the names of the images to be renamed. +.le +.ls newnames +Either an image template specifying the new names for the images, +or the name of the directory to which the images are to be renamed (moved). +.le +.ls verbose = no +If verbose output is enabled a message will be printed on the standard output +recording each rename operation. +.le +.ih +DESCRIPTION +The \fBimrename\fR task renames one or more images. The ordinary \fIrename\fR +task cannot be used to rename images since an image may consist of more than +one file. +.ih +EXAMPLES +1. Rename the image "pix" to "wfpc.1". + + cl> imrename pix wfpc.1 + +2. Rename all the "nite1*" images as "nite1_c". + + cl> imrename nite1.*.imh nite1%%_c%.*.imh + +3. Move the images in logical directory "dd" to the current directory. + + cl> imrename dd$*.imh . + +4. Move the pixel files associated with the images in the current directory +to a subdirectory "pix" of the current directory. + +.nf + cl> reset imdir = HDR$pix/ + cl> imrename *.imh . +.fi +.ih +SEE ALSO +imcopy, imdelete, imheader +.endhelp diff --git a/pkg/images/imutil/doc/imreplace.hlp b/pkg/images/imutil/doc/imreplace.hlp new file mode 100644 index 00000000..80e9f12c --- /dev/null +++ b/pkg/images/imutil/doc/imreplace.hlp @@ -0,0 +1,72 @@ +.help imreplace Dec97 images.imutil +.ih +NAME +imreplace -- replace pixels in a window by a constant +.ih +USAGE +imreplace images value lower upper +.ih +PARAMETERS +.ls images +Images in which the pixels are to be replaced. +.le +.ls value +Replacement value for pixels in the window. +.le +.ls imaginary = 0. +Replacement value for pixels in the windoe for the imaginary part of +complex data. +.le +.ls lower = INDEF +Lower limit of window for replacing pixels. If INDEF then all pixels +are above \fIlower\fR. For complex images this is the magnitude +of the pixel values. For integer images the value is rounded up +to the next higher integer. +.le +.ls upper = INDEF +Upper limit of window for replacing pixels. If INDEF then all pixels +are below \fIupper\fR. For complex images this is the magnitude +of the pixel values. For integer images the value is rounded down +to the next lower integer. +.le +.ls radius = 0. +Additional replacement radius around pixels which are in the replacement +window. If a pixel is within this distance of a pixel within the replacement +window it is also replaced with the replacement value. Distances are +measured between pixel centers which are have integer coordinates. +.le +.ih +DESCRIPTION +The pixels in the \fIimages\fR between \fIlower\fR and \fIupper\fR, +and all other pixels with a distance given by \fIradius\fR, +are replaced by the constant \fIvalue\fR. The special value INDEF in +\fIlower\fR and \fIupper\fR corresponds to the minimum and maximum +possible pixel values, respectively. + +For complex images the replacement value is specified as separate +real and imaginary and the thresholds are the magnitude. For +integer images the thresholds are used as inclusive limits +so that, for example, the range 5.1-9.9 affets pixels 6-9. +.ih +EXAMPLES +1. In a flat field calibration which has been scaled to unit mean replace +all response values less than or equal to 0.8 by 1. + + cl> imreplace calib 1 upper=.8 + +2. Set all pixels to zero within a section of an image. + + cl> imreplace image[1:10,5:100] 0 +.ih +REVISIONS +.ls IMREPLACE V2.11.1 +A replacement radius to replace additional pixels was added. +.le +.ls IMREPLACE V2.11 +The lower value is now rounded up for integer images so that a range +like 5.1-9.9 affects pixels 6-9 instead of 5-9. +.le +.ih +SEE ALSO +imexpr +.endhelp diff --git a/pkg/images/imutil/doc/imslice.hlp b/pkg/images/imutil/doc/imslice.hlp new file mode 100644 index 00000000..368240d0 --- /dev/null +++ b/pkg/images/imutil/doc/imslice.hlp @@ -0,0 +1,58 @@ +.help imslice Feb90 images.imutil +.ih +NAME +imslice -- slice an image into images of lower dimension +.ih +USAGE +imslice input output slicedim +.ih +PARAMETERS +.ls input +The list of input images to be sliced. The input images must have a +dimensionality greater than one. +.le +.ls output +The root name of the output images. For each n-dimensional input +image m (n-1)-dimensional images will be created, where m is the +length of the axis to be sliced. The sequence number m will +be appended to the output image name. +.le +.ls slice_dimension +The dimension to be sliced. +.le +.ls verbose = yes +Print messages about actions taken. +.le +.ih +DESCRIPTION +The n-dimensional images \fIinput\fR are sliced into m (n-1)-dimensional +images \fIoutput\fR, where m is the length of the axis of the input +image to be sliced. A sequence number from 1 to m is appended to output +to create the output image name. +.ih +EXAMPLES +1. Slice the 3-D image "datacube" into a list of 2D images. A list of +images called plane001, plane002, plane003 ... will be created. + +.nf + im> imslice datacube plane 3 +.fi + +2. Slice the list of 2-D images "nite1,nite2,nite3" into a list of 1-D images. +A new list of images nite1001, nite1002, ..., nite2001, nite2002, ..., +nite3001, nite3002 will be created. + +.nf + im> imslice nite1,nite2,nite3 nite1,nite2,nite3 2 +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +If the image to be sliced is an image section, the images slices will +refer to the section not the original image. +.ih +SEE ALSO +imstack, imcopy +.endhelp diff --git a/pkg/images/imutil/doc/imstack.hlp b/pkg/images/imutil/doc/imstack.hlp new file mode 100644 index 00000000..e3eeccd9 --- /dev/null +++ b/pkg/images/imutil/doc/imstack.hlp @@ -0,0 +1,56 @@ +.help imstack Apr92 images.imutil +.ih +NAME +imstack -- stack images into an image of higher dimension +.ih +USAGE +imstack images output +.ih +PARAMETERS +.ls images +List of images to be stacked. +.le +.ls output +Name of output image created. +.le +.ls title = "*" +Title of output image. If "*" then the title defaults to that of +the first input image. +.le +.ls pixtype = "*" +Pixel datatype of output image. If "*" then the pixel datatype defaults to +that of the first input image. +.le +.ih +DESCRIPTION + +The input \fIimages\fR are stacked to form an \fIoutput\fR image having one +higher dimension than the input images, and a length of that dimension equal +to the number of input images. The input images must all be of the same +dimension and size. + +The output image inherits the world coordinate system (WCS) of the first +input image. If the dimension of the input image WCS is greater than or +equal to the dimension of the output image, the input WCS is copied to the +output image WCS without modification. Otherwise the input image WCS +dimension is incremented by 1 and copied to the output image WCS, the input +WCS coordinate transformations for each input image axis are copied to the +output image WCS without modification, and the new output image axis is +assigned a WCS type of 'linear' and the identity transformation. + +.ih +EXAMPLES + +1. Stack a set of four two dimensional images: + + cl> imstack image* image.3d + +2. To stack a section of images: + + cl> imstack image*[1:10,1:10] newimage +.ih +BUGS +.ih +SEE ALSO +imslice +.endhelp diff --git a/pkg/images/imutil/doc/imstat.hlp b/pkg/images/imutil/doc/imstat.hlp new file mode 100644 index 00000000..ed5183d9 --- /dev/null +++ b/pkg/images/imutil/doc/imstat.hlp @@ -0,0 +1,121 @@ +.help imstatistics Feb01 images.imutil +.ih +NAME +imstatistics -- compute and print image pixel statistics +.ih +USAGE +imstatistics images +.ih +PARAMETERS +.ls images +The input images or image sections for which pixel statistics are to be +computed. +.le +.ls fields = "image,npix,mean,stddev,min,max" +The statistical quantities to be computed and printed. +.le +.ls lower = INDEF +The minimum good data limit. All pixels are above the default value of INDEF. +.le +.ls upper = INDEF +The maximum good data limit. All pixels are above the default value of INDEF. +.le +.ls nclip = 0 +The maximum number of iterative clipping cycles. By default no clipping is +performed. +.le +.ls lsigma = 3.0 +The low side clipping factor in sigma. +.le +.ls usigma = 3.0 +The high side clipping factor in sigma. +.le +.ls binwidth = 0.1 +The width of the histogram bins used for computing the midpoint (estimate +of the median) and the mode. +The units are in sigma. +.le +.ls format = yes +Label the output columns and print the result in fixed format. If format +is "no" no column labels are printed and the output is in free format. +.le +.ls cache = no +Cache the image data in memory ? This can increase the efficiency of the +task if nclip > 0 or either of the midpt and mode statistics are computed. +.le +.ih +DESCRIPTION +The statistical quantities specified by the parameter \fIfields\fR are +computed and printed for each image in the list specified by \fIimages\fR. +The results are printed in tabular form with the fields listed in the order +they are specified in the fields parameter. The available fields are the +following. + +.nf + image - the image name + npix - the number of pixels used to do the statistics + mean - the mean of the pixel distribution + midpt - estimate of the median of the pixel distribution + mode - the mode of the pixel distribution + stddev - the standard deviation of the pixel distribution + skew - the skew of the pixel distribution + kurtosis - the kurtosis of the pixel distribution + min - the minimum pixel value + max - the maximum pixel value +.fi + +The mean, standard deviation, skew, kurtosis, min and max are computed in a +single pass through the image using the expressions listed below. +Only the quantities selected by the fields parameter are actually computed. + +.nf + mean = sum (x1,...,xN) / N + y = x - mean + variance = sum (y1 ** 2,...,yN ** 2) / (N-1) + stddev = sqrt (variance) + skew = sum ((y1 / stddev) ** 3,...,(yN / stddev) ** 3) / (N-1) + kurtosis = sum ((y1 / stddev) ** 4,...,(yN / stddev) ** 4) / (N-1) - 3 +.fi + +The midpoint and mode are computed in two passes through the image. In the +first pass the standard deviation of the pixels is calculated and used +with the \fIbinwidth\fR parameter to compute the resolution of the data +histogram. The midpoint is estimated by integrating the histogram and +computing by interpolation the data value at which exactly half the +pixels are below that data value and half are above it. The mode is +computed by locating the maximum of the data histogram and fitting the +peak by parabolic interpolation. + +.ih +EXAMPLES +1. To find the number of pixels, mean, standard deviation and the minimum +and maximum pixel value of a bias region in an image. + +.nf + cl> imstat flat*[*,1] + # IMAGE NPIX MEAN STDDEV MIN MAX + flat1[*,1] 800 999.5 14.09 941. 1062. + flat2[*,1] 800 999.4 28.87 918. 1413. +.fi + +The string "flat*" uses a wildcard to select all images beginning with the +word flat. The string "[*,1]" is an image section selecting row 1. + +2. Compute the mean, midpoint, mode and standard deviation of a pixel +distribution. + +.nf + cl> imstat m51 fields="image,mean,midpt,mode,stddev" + # IMAGE PIXELS MEAN MIDPT MODE STDDEV + M51 262144 108.3 88.75 49.4 131.3 +.fi + +.ih +BUGS +When using a very large number of pixels the accumulation of the sums +of the pixel values to the various powers may +encounter roundoff error. This is significant when the true standard +deviation is small compared to the mean. +.ih +SEE ALSO +.endhelp diff --git a/pkg/images/imutil/doc/imsum.hlp b/pkg/images/imutil/doc/imsum.hlp new file mode 100644 index 00000000..a6eb07a5 --- /dev/null +++ b/pkg/images/imutil/doc/imsum.hlp @@ -0,0 +1,132 @@ +.help imsum Sep87 images.imutil +.ih +NAME +imsum -- sum, average, or median images +.ih +USAGE +imsum input output +.ih +PARAMETERS +.ls input +Input images. +.le +.ls output +Output image. +.le +.ls title = "" +Image title for the output image. If null ("") then the title of the +first image is used. +.le +.ls hparams = "" +List of image header parameters to be summed or averaged. This feature +is only used when summing or averaging and no correction is made for +rejected pixels. It is primarily used to sum exposure times. +.le +.ls pixtype = "" +Pixel datatype for the output image. The pixel datatypes are "double", +"real", "long", "integer", "ushort", and "short" in order of precedence. +If null ("") then the calculation type is used. +The datatypes may be abbreviated to a single character. +.le +.ls calctype = "" +Calculation type. The calculation types are "double", "real", "long", +"integer", and "short" in order of precedence. If null ("") then the +highest precedence datatype of the input images is used. +If there is a mixture of "short" and "ushort" images then the highest +precedence datatype will be "int". +The calculation types may be abbreviated to a single character. +.le +.ls option = "sum" +Output options are "sum", "average", or "median". The "median" of an +even number of images takes pixel nimages/2 + 1, where nimages is the +number of images. +.le +.ls low_reject = 0 +If the option is sum or average then when this parameter +is less than 1 reject this fraction of low pixels from the sum or average +otherwise reject this number of low pixels from the sum or average. +.le +.ls high_reject = 0 +If the option is sum or average then when this parameter +is less than 1 reject this fraction of high pixels from the sum or average +otherwise reject this number of high pixels from the sum or average. +.le +.ls verbose = no +Print a log of the operation? +.le +.ih +DESCRIPTION +The input images are summed, averaged, or medianed pixel by pixel and the +result recorded in the output image. All input images must be the same +size but not necessarily of the same pixel datatype. For the sum or average +option a selected fraction or number of pixels may be rejected. The output +option "average" divides the sum by the number of pixels in the sum. The +pixel datatype of the output image may be selected or defaulted to the +calculation datatype. The calculation type may be selected or defaulted +to the highest precedence datatype of the input images. Note that a +mixture of "short" and "ushort" images has a highest precedence datatype +of "int". If all the image pixel datatypes are the same and agree with the +calculation type then this operation is maximally efficient. However, +beware of integer overflows with images of datatype short or ushort. A log +of the task name, the input image names, the output image name, the output +pixel datatype, the output option, and the pixel rejection parameters is +printed when the verbose parameter is yes. + +In addition to summing the pixels the specified image header parameters may +be summed or averaged. This is primarily used for summing image exposure +times. No correction is made for rejected pixels. +.ih +EXAMPLES +1. To sum three images: + + im> imsum frame1,frame2,frame3 sum hparams="itime,exposure" + +2. To make a median image of a set of images: + + im> imsum obs* median option=median + +where '*' is a template wildcard. + +3. To reject the lowest and highest 2 pixels and average the rest: + + im> imsum obs* avg option=average low=2 high=2 +.ih +REVISIONS +.ls IMSUM V2.11 +Now allows "ushort" data types. +.le +.ih +TIME REQUIREMENTS +The following timings are for 512 x 512 short images in which the output +image is also short and the calculation type is short. + +.nf + OPERATION CPU(sec) + 1. Sum of 3 7.4 + 2. Average of 3 13.0 + 3. Median of 3 9.9 + 4. Sum of 5 13.0 + 5. Median of 5 23.0 + 6. Sum of middle 3 of 5 45.5 + 7. Median of 7 77.8 +.fi +.ih +NOTES +Any number of images may be used. However, there is a maximum number of +images which may be open at one time. If the number of images +(of dimension >= 2) exceeds this maximum and median or pixel rejection is +used then the performance of this task will suffer due to the need to +repeatedly open and close the excess images. The maximum number is a +configurable parameter in the include file "imsum.h". + +This task has been largely replaced by the task \fBimcombine\fR. It is +still available but may be removed in the future. \fBImcombine\fR is +specially designed to deal with the case of large numbers of images. +.ih +BUGS +It is an error for the output image to have the same name as an +existing image. Beware of integer overflows when summing short images. +.ih +SEE ALSO +imcombine +.endhelp diff --git a/pkg/images/imutil/doc/imtile.hlp b/pkg/images/imutil/doc/imtile.hlp new file mode 100644 index 00000000..b3a26924 --- /dev/null +++ b/pkg/images/imutil/doc/imtile.hlp @@ -0,0 +1,151 @@ +.help imtile Jan97 images.imutil +.ih +NAME +imtile -- mosaic a list of same size images into a tile pattern +.ih +USAGE +imtile input output nctile nltile +.ih +PARAMETERS +.ls input +The list of input image tiles to be mosaiced. The image tile list is assumed +to be ordered by row, column, or in a raster pattern. If the image tile list +is not in order then the files or sections tasks plus the editor must be used +to construct an ordered image tile list. The images in the input list must +all be the same size. +.le +.ls output +The name of the output image. +.le +.ls nctile +The number of image tiles to be placed along a row of the output image. +.le +.ls nltile +The number of image tiles to be placed along a column of the output image. +.le +.ls trim_section = "[*,*]" +The section of the input image tiles to be inserted into the output image. +Trim_section can be used to flip and / or trim the individual image tiles +before adding them to the mosaic. For example if we want to flip each +image tile around the y axis before adding it to the mosaic, then +\fItrim_section\fR should be set to "[*,-*]". +.le +.ls missing_input = "" +The list of missing image tiles. For example if image tiles 3 to 5 and +10 from a sequence of image tiles are missing then \fImissing_input\fR = +"3-5,10". This parameter uses the IRAF ranges syntax. The number of missing +image tiles plus the number of input image tiles must equal \fInctile\fR * +\fInltile\fR. +.le +.ls start_tile = "ll" +The position of the first input image tile placed in the output image mosaic. +The four options are "ll" for lower left corner, "lr" for lower right corner, +"ul" for upper left corner and "ur" for upper right corner. +.le +.ls row_order = yes +Add the input image tiles to the output image in row order. If row_order is +"no" then column order is used instead. +.le +.ls raster_order = no +Add the input image tiles to the output image in a raster pattern or return +to the start of a column or a row before adding a new image tile ? +.le +.ls median_section = "" +The section of each input image tile used to compute the median value. If +\fImedian_section\fR is the null string then the medians are not computed. +If \fImedian_section\fR is "[*,*]" the entire input image tile is used to +compute the median. +.le +.ls subtract = no +Subtract the median value from each input image tile before placing the +tile in the output image? +.le +.ls ncols = INDEF +The number of columns in the output image. If \fIncols\fR is INDEF then +the program will compute the number of columns using the size of the input +image tiles, \fInctile\fR, and \fIncoverlap\fR. +.le +.ls nlines = INDEF +The number of lines in the output image. If \fInlines\fR is INDEF then +the program will compute the number of lines using the size of the input +image tiles, \fInltile\fR and \fInloverlap\fR. +.le +.ls ncoverlap = -1 +The number of columns between adjacent tiles in the output image. A negative +value specifies the amount of column space between adjacent tiles. A positive +value specifies the amount of column overlap on adjacent tiles. +.le +.ls nloverlap = -1 +The number of lines between adjacent tiles in the output image. A negative +value specifies the amount of lines space between adjacent tiles. A positive +value specifies the amount of line overlap on adjacent tiles. +.le +.ls ovalue = 0.0 +The output image pixel value in regions undefined by the list of input +image tiles. +.le +.ls opixtype = "r" +The pixel type of the output image. The options are "s" (short integer), +"i" (integer), "u" (ushort), "l" (long integer), "r" (real) and +"d" for double precision. +.le +.ls verbose = yes +Print messages about the progress of the task? +.le + +.ih +DESCRIPTION + +IMTILE takes the list of same size input images (image tiles) specified by +\fIinput\fR and combines them into a tiled output image mosaic \fIoutput\fR. +The order in which the input image tiles are placed in the output image is +determined by the parameters \fIstart_tile\fR, \fIrow_order\fR and +\fIraster_order\fR. The orientation of each individual image tile in the +output image is set by the \fItrim_section\fR parameter. + +IMTILE uses the input image tile size, the number of image tiles, the +\fIncoverlap\fR and \fRnloverlap\fI parameters, and the \fInctile\fR and +\fInltile\fR parameters to compute the size of the output image. An image +of size larger than the minimum required can be specified by setting the +\fIncols\fR and \fInlines\fR parameters. The pixel type of the output +image is specified by the \fIopixtype\fR parameter and undefined +regions of the output image are assigned the value \fIovalue\fR. + +The median of a section of each input image tile is computed by setting +the \fImedian_section\fR parameter, and the computed median is subtracted +from the input image tiles if the \fIsubtract\fR parameter is set to "yes". +Task action messages will be printed on the standard output +if \fIverbose\fR is set to yes. + +.ih +EXAMPLES + +1. Mosaic a list of 64 images onto an 8 by 8 grid in column order +starting in the upper right hand corner. Allow one blank column and row +between each subraster. + +.nf + cl> imtile @imlist mosaic 8 8 ncoverlap=-1 nloverlap=-1 \ + start_tile="ur" row- +.fi + +2. Mosaic a list of 62 images onto an 8 by 8 grid in column order +starting in the upper right hand corner. Allow one blank column and row +between each subraster. Subrasters 3 and 9 in the sequence do not exist +and are to be replaced in the output image with an unknown value of -1.0. + +.nf + cl> imtile @imlist mosaic 8 8 nxoverlap=-1 nyoverlap=-1 \ + start_corner="ur" row- missing_input="3,9", ovalue=-1.0 +.fi + +.ih +TIME REQUIREMENTS + +.ih +BUGS + +.ih +SEE ALSO +imcombine +.endhelp diff --git a/pkg/images/imutil/doc/listpixels.hlp b/pkg/images/imutil/doc/listpixels.hlp new file mode 100644 index 00000000..48ea89eb --- /dev/null +++ b/pkg/images/imutil/doc/listpixels.hlp @@ -0,0 +1,191 @@ +.help listpixels Apr92 images.imutil +.ih +NAME +listpixels -- print the pixel values for a list of images +.ih +USAGE +listpixels images +.ih +PARAMETERS +.ls images +Images or list of image sections whose pixels are to be printed. +.le +.ls wcs = "logical" +The world coordinate system to be used for coordinate output. The following +standard systems are defined. +.ls logical +Logical coordinates are image pixel coordinates relative to the input +image. For example the pixel coordinates of the lower left corner +of an image section will always be (1,1) in logical units regardless of +their values in the original image. +.le +.ls physical +Physical coordinates are image pixel coordinates with respect to the original +image. For example the pixel coordinates of the lower left corner +of an image section will be its coordinates in the original image, +including the effects of any linear transformations done on that image. +Physical coordinates are invariant with respect to transformations +of the physical image matrix. +.le +.ls world +World coordinates are image pixel coordinates with respect to the +current default world coordinate system. For example in the case +of spectra world coordinates would most likely be in angstroms. +The default world coordinate system is the system named by the environment +variable \fIdefwcs\fR if defined in the user environment and present in +the image world coordinate system description, else it is the first user +world coordinate system defined for the image, else physical coordinates +are returned. +.le + +In addition to these three reserved world coordinate system names, the names +of any user world coordinate system defined for the image may be given. +.le +.ls formats = "" +The default output formats for the pixel coordinates, one format +per axis, with the individual formats separated by whitespace . +If formats are undefined, listpixels uses the formatting options +stored with the WCS in the image header. If the WCS formatting options +are not stored in the image header, then listpixels uses a default +value. +.le +.ls verbose = no +Print a title line for each image whose pixels are to be listed. +.le +.ih +DESCRIPTION +The pixel coordinates in the world coordinates system specified by +\fIwcs\fR and using the formats specified by \fIformats\fR are +printed on the standard output on the standard output followed by +the pixel value. +.ih +FORMATS +A format specification has the form "%w.dCn", where w is the field +width, d is the number of decimal places or the number of digits of +precision, C is the format code, and n is radix character for +format code "r" only. The w and d fields are optional. The format +codes C are as follows: + +.nf +b boolean (YES or NO) +c single character (c or '\c' or '\0nnn') +d decimal integer +e exponential format (D specifies the precision) +f fixed format (D specifies the number of decimal places) +g general format (D specifies the precision) +h hms format (hh:mm:ss.ss, D = no. decimal places) +m minutes, seconds (or hours, minutes) (mm:ss.ss) +o octal integer +rN convert integer in any radix N +s string (D field specifies max chars to print) +t advance To column given as field W +u unsigned decimal integer +w output the number of spaces given by field W +x hexadecimal integer +z complex format (r,r) (D = precision) + + +Conventions for w (field width) specification: + + W = n right justify in field of N characters, blank fill + -n left justify in field of N characters, blank fill + 0n zero fill at left (only if right justified) +absent, 0 use as much space as needed (D field sets precision) + + +Escape sequences (e.g. "\n" for newline): + +\b backspace (not implemented) +\f formfeed +\n newline (crlf) +\r carriage return +\t tab +\" string delimiter character +\' character constant delimiter character +\\ backslash character +\nnn octal value of character + +Examples + +%s format a string using as much space as required +%-10s left justify a string in a field of 10 characters +%-10.10s left justify and truncate a string in a field of 10 characters +%10s right justify a string in a field of 10 characters +%10.10s right justify and truncate a string in a field of 10 characters + +%7.3f print a real number right justified in floating point format +%-7.3f same as above but left justified +%15.7e print a real number right justified in exponential format +%-15.7e same as above but left justified +%12.5g print a real number right justified in general format +%-12.5g same as above but left justified + +%h format as nn:nn:nn.n +%15h right justify nn:nn:nn.n in field of 15 characters +%-15h left justify nn:nn:nn.n in a field of 15 characters +%12.2h right justify nn:nn:nn.nn +%-12.2h left justify nn:nn:nn.nn + +%H / by 15 and format as nn:nn:nn.n +%15H / by 15 and right justify nn:nn:nn.n in field of 15 characters +%-15H / by 15 and left justify nn:nn:nn.n in field of 15 characters +%12.2H / by 15 and right justify nn:nn:nn.nn +%-12.2H / by 15 and left justify nn:nn:nn.nn + +\n insert a newline +.fi +.ih +EXAMPLES +1. List the pixels of an image on the standard output. + +.nf + cl> listpix m81 +.fi + +2. List a subraster of the above image in logical coordinates. + +.nf + cl> listpix m81[51:55,151:155] + 1. 1. ... + 2. 1. ... + 3. 1. ... + 4. 1. ... + 5. 1. ... + 1. 2. ... + .. .. ... +.fi + +3. List the same subraster in physical coordinates. + +.nf + cl> listpix m81[51:55,151:155] wcs=physical + 51. 151. ... + 52. 151. ... + 53. 151. ... + 54. 151. ... + 55. 151. ... + 51. 152. ... + ... .... ... +.fi + +4. List a spectrum that has been dispersion corrected in angstrom units. + +.nf + cl> listpix n7027 wcs=world +.fi + +5. List the RA and DEC coordinates in hms and dms format and pixels value +for an image section where axis 1 is RA and axis 2 is DEC. + +.nf + cl> listpix m51 wcs=world formats="%H %h" +.fi + +.ih +TIME REQUIREMENTS +.ih +BUGS +.ih +SEE ALSO +imheader, imgets, imhistogram +.endhelp diff --git a/pkg/images/imutil/doc/minmax.hlp b/pkg/images/imutil/doc/minmax.hlp new file mode 100644 index 00000000..6e3f39b2 --- /dev/null +++ b/pkg/images/imutil/doc/minmax.hlp @@ -0,0 +1,84 @@ +.help minmax May91 images.imutil +.ih +NAME +minmax -- compute the minimum and maximum pixel values of an image +.ih +USAGE +minmax images +.ih +PARAMETERS +.ls images +Image template specifying the images to be examined. +.le +.ls force = no +Force recomputation of the minimum and maximum pixel and pixel values even if +they are noted as up to date in the image header. +.le +.ls update = yes +Update the image header with the new values (requires write permission). +.le +.ls verbose = yes +Print the image name, minimum value, and maximum value of each image +processed. +.le +.ls minval = INDEF +Set to the minimum pixel value of the last image processed. +If the pixel type of the last input image was complex, this is the real +part of the minimum value. +.le +.ls maxval = INDEF +Set to the maximum pixel value of the last image processed. +If the pixel type of the last input image was complex, this is the real +part of the maximum value. +.le +.ls iminval = INDEF +Set to the minimum imaginary part of the pixel value of the last image +processed. Only used if the pixel type of the last input image was complex. +.le +.ls imaxval = INDEF +Set to the maximum imaginary part of the pixel value of the last image +processed. Only used if the pixel type of the last input image was complex. +.le +.ls minpix = "" +Set to the minimum pixel specification of the last image processed. +.le +.ls maxpix = "" +Set to the maximum pixel specification of the last image processed. +.le +.ih +DESCRIPTION + + The \fIminmax\fR task computes the minimum and maximum pixel and pixel +values of +each of the images or image sections listed in the image template \fIimages\fR. +If the \fIforce\fR option is set the extreme values will be recomputed by +physical examination of the data, otherwise the image is examined only if the +extreme values stored in the image header are flagged as invalid. +The minimum and maximum pixel will be printed only if the force option +is enabled or if the image minimum and maximum is out of date. +If the \fIupdate\fR option is set the image header will be updated with the +newly computed values. Updating is not allowed when a section is used to +compute the new values. +.ih +EXAMPLES +1. Compute and print the minimum and maximum values of the images \fIimage1\fR +and \fIimage2\fR, updating the image header with the new values when done. + +.nf + cl> minmax image1,image2 +.fi + +2. Force update the minimum and maximum values in the image headers of all +images matching the template in the background, without printing the computed +values on the terminal. + + cl> minmax nite1.* force+ verbose- & +.ih +BUGS +The minimum and maximum pixel values are stored in the image header as values +of type real, hence some precision may be lost for images of type long integer +or double precision floating. +.ih +SEE ALSO +imheader, hedit +.endhelp diff --git a/pkg/images/imutil/doc/nhedit.hlp b/pkg/images/imutil/doc/nhedit.hlp new file mode 100644 index 00000000..27efffcc --- /dev/null +++ b/pkg/images/imutil/doc/nhedit.hlp @@ -0,0 +1,499 @@ +.help nhedit Aug08 images.imutil +.ih +NAME +nhedit - edit or view an image header interactively or using a command file +.ih +USAGE +.nf +nhedit images fields value comment +.fi +.ih +PARAMETERS +.ls images +Template specifying the images to be edited. +.le +.ls fields +Template specifying the fields to be edited in each image. The template is +expanded independently for each image against the set of all fields in the +image header. Special values for fields includes 'default_pars' that works only +with a command file; 'add_blank' to add a blank field value with a string as +value; 'add_textf' to add a text file content to the header. See description +for more details. +.le +.ls value +Either a string constant or a general expression (if the first character is +a left parenthesis) to be evaluated to compute the new value of each field. +With the rename switch the value is the new field name (keyword). +A single expression is used for all fields. The special value "." causes the +value of each field to be printed rather than edited. +.le +.ls comment +String constant for the comment section of the header card. This value will +replace the existing comment of a header or clear it if is empty (""). +The special value "." causes the field to be printed rather than edited. +.le +.ls comfile = "" +Alternate command file. If specified, the \fIfields\fR, \fIvalue\fR, and +\fIcomment\fR parameters are ignored and commands are taken from the named +file. See below for a detailed discussion and examples. +.le +.ls after = "" +Insert the new field after the named "pivot keyword". If this keyword +does not exist in the header, the new keyword is added to the end of the +image header. +.le +.ls before = "" +Insert the new field before the named "pivot keyword". If this keyword +does not exist in the header, the new keyword is added to the end of the +image header. +.le +.ls add = no +Change the operation of the editor from update to add new field. If the +field already exists it is edited. If this option is selected the field +list may name only a single field. The add switch takes precedence +over the addonly, delete, and rename switches. +.le +.ls addonly = no +Change the operation of the editor from update to add a new field. If the +field already exists it is not changed. If this option is selected the field +list may name only a single field. The addonly switch takes precedence over +the delete and rename switches. +.le +.ls delete = no +Change the operation of the editor from update to delete field. +The listed fields are deleted from each image. This takes precedence +or the rename switch. +.le +.ls rename = no +Change the operation of the editor from update field to rename field. +The listed fields are renamed in each image if they exist. The value +is parameter specifies the new keyword name. There is +no error if the field does not exist. The comment value is ignored +since this operation only affects the field name. +.le +.ls verify = yes +Interactively verify all operations which modify the image database. +The editor will describe the operation to be performed, prompting with the +new value of the parameter in the case of a field edit. Type carriage +return or "yes" to complete the operation, or enter a new value explicitly +as a string. Respond with "no" if you do not wish to change the value of +the parameter. +.le +.ls show = yes +Print a record of each operation which modifies the database upon the standard +output. Old values are given as well as new values, making it possible to +undo an edit operation. +.le +.ls update = yes +Enable updating of the image database. If updating is disabled the edit +operations are performed in memory but image headers will not be updated +on disk. +.le +.ih +DESCRIPTION + +1. Basic Usage + + The most basic functions of the image header editor are modification and +inspection of the fields of an image header. Both the "standard" and +"user" fields may be edited in the same fashion, although not all standard +fields are writable. For example, to change the value of the standard field +"title" of the image "m74" to "sky flat" and enter a comment field we +would enter the following command. + + cl> nhedit m74 title "sky flat" "comment field" + +If \fIverify\fR mode is selected the editor will print the old value of the +field and query with the new value, allowing some other value to be entered +instead, e.g.: + +.nf + cl> nhedit m74 title "sky flat" "comment field" + m74,i_title ("old title" -> "sky flat"): +.fi + +To accept the new value shown to the right of the arrow, type carriage +return or "yes" or "y" followed by carriage return. To continue without +changing the value of the field in question enter "no" or "n" followed by +carriage return. To enter some other value merely type in the new value. +If the new value is one of the reserved strings, e.g., "yes" or "no", +enter it preceded by a backslash. If verification is enabled you will +also be asked if you want to update the header, once all header fields +have been edited. This is your last chance to change your mind before +the header is modified on disk. If you respond negatively the image header +will not be updated, and editing will continue with the next image. +If the response is "q" the editor will exit entirely. + +To conveniently print the value of the field "title" without modifying +the image header, we repeat the command with the special value "." and "." +for the comment portion. + + cl> nhedit m74 title . . + +To print (or edit) the values of all header fields a field template may be +given. + + cl> nhedit m74 * . . + +To print (or edit) the values of only a few fields the field template may +be given as a list. + + cl> nhedit m74 w0,wpc . . + +To print the value of one or more fields in a set of images, an image template +may be given. Both image templates and field templates may be given if +desired. + + cl> nhedit n1.* exp . . + +Abbreviations are not permitted for field names, i.e., the given template +must match the full field name. Currently, field name matches are case +insensitive since image headers are often converted to and from FITS headers, +which are case insensitive. + + +2. Advanced Usage + + The header editor is capable of performing global edits on entire image +databases wherein the new value of each field is computed automatically at +edit time and may depend on the values of other fields in the image header. +Editing may be performed in either batch or interactive mode. An audit trail +may be maintained (via the \fIshow\fR switch and i/o redirection), permitting +restoration of the database in the event of an error. Trial runs may be made +with updating disabled, before committing to an actual edit which modifies the +database. + +The major editing functions of the \fInhedit\fR task are the following: + +.nf + update modify the value of a field or fields + addonly add a new field + add add a new field or modify an old one + delete delete a set of fields + rename rename a set of fields +.fi + +In addition, \fInhedit\fR may be used merely to inspect the values of the header +fields, without modification of the image database. + +2.1 Special header fields + +.ks +.nf + add_blank Add blank keyword field with optional comment + ex: nhedit add_blank " this is a comment with no kw" + add_textf Add the content of a text file into the header + ex: nhedit add_textf "my_text.txt" add+ +.fi +.ke + +All keyword addition can be inserted after or before an existent keyword; use +the 'after' and 'before' parameter. + +2.2 Input commands from a command file. + +All header editing command can be put together in a text file and run it as: + +nhedit file*.fits comfile=command_file.txt + +2.3 Standard header fields + + The header editor may be used to access both the standard image header +fields and any user or application defined fields. The standard header fields +currently defined are shown below. There is no guarantee that the names and/or +usage of these fields will not change in the future. + + +.ks +.nf + i_ctime int create time + i_history string history comments + i_limtime int time when min,max last updated + i_maxpixval real maximum pixel value + i_minpixval real minimum pixel value + i_mtime int time of last modify + i_naxis int number of axes (dimensionality) + i_naxis[1-7] int length of each axis + i_pixfile string pathname of pixel storage file + i_pixtype int pixel datatype code + i_title string title string +.fi +.ke + + +The standard header field names have an "i_" prefix to reduce the possibility +of a name collision with a user field name, and to distinguish the two classes +of parameters in templates. The prefix may be omitted provided the simple +name is unique. + + +2.4 Field name template + + The form of the field name list or template parameter \fIfields\fR is +equivalent to that of a filename template except that "@listfile" is not +supported, and of course the template is expanded upon the field name list +of an image, rather than upon a directory. Abbreviations are not permitted +in field names and case is not significant. Case is ignored in this context +due to the present internal storage format for the user parameters (FITS), +which also limits the length of a user field name to 8 characters. + + +2.5 Value expression + + The \fIvalue\fR parameter is a string type parameter. If the first +character in the string is a left parenthesis the string is interpreted as +an algebraic expression wherein the operands may be constants, image header +variables (field names), special variables (defined below), or calls to +intrinsic functions. The expression syntax is equivalent to that used in +the CL and SPP languages. If the value string is not parenthesized it is +assumed to be a string constant. The \fIvalue\fR string will often contain +blanks, quotes, parenthesis, etc., and hence must usually be quoted to avoid +interpretation by the CL rather than by the header editor. + +For example, the command + + cl> nhedit m74 title "title // ';ss'" "." + +would change the title to the literal string constant "title // ';ss'", +whereas the command + + cl> nhedit m74 title "(title // ';ss')" "." + +would concatenate the string ";ss" to the old title string. We require +parenthesis for expression evaluation to avoid the need to doubly quote +simple string constant values, which would be even more confusing for the +user than using parenthesis. For example, if expressions did not have to +be parenthesized, the first example in the basic usage section would have +to be entered as shown below. + + cl> nhedit m74 title '"sky flat"' # invalid command + +Expression evaluation for \fInhedit\fR, \fIhselect\fR, and similar tasks +is carried out internally by the FMTIO library routine \fBevexpr\fR. +For completeness minimal documentation is given here, but the documentation +for \fIevexpr\fR itself should be consulted if additional detail is required +or if problems occur. + + +2.5.1 operators + + The following operators are recognized in value expressions. With the +exception of the operators "?", "?=", and "@", the operator set is equivalent +to that available in the CL and SPP languages. + + +.nf + + - * / arithmetic operators + ** exponentiation + // string concatenation + ! - boolean not, unary negation + < <= > >= order comparison (works for strings) + == != && || equals, not equals, and, or + ?= string equals pattern + ? : conditional expression + @ reference a variable +.fi + + +The operators "==", "&&", and "||" may be abbreviated as "=", "&", and "|" +if desired. The ?= operator performs pattern matching upon strings. +For example, the boolean expression shown below will be true whenever the +field "title" contains the substring "sky". + + (title ?= '*sky*') + +The conditional expression operator '?', which is patterned after a similar +operator in C, is used to make IF ELSE like decisions within an expression. +The syntax is as follows: + + '?' ':' + +e.g., the expression + + ((a > b) ? 1 : 0) + +has the value 1 if A is greater than B, and 0 otherwise. The datatypes +of the true and false expressions need not be the same, unlike a compiled +language. Note that if the parenthesis are omitted ambiguous forms of +the expression are possible, e.g.: + + (a > b) ? 1 : a + 1 + +could be interpreted either as + + ((a > b) ? 1 : a) + 1 +or as + (a > b) ? 1 : (a + 1) + +If the parenthesis are omitted the latter interpretation is assumed. + +The operator @ must be used to dereference variables that have names with +funny (nonalphanumeric) characters in them, forcing the variable name to +be given as a string constant. For example, the value of the expression + + @"co-flag" + +is the value of the variable "co-flag". If the variable were referenced +directly by name the "-" would be interpreted as the subtraction operator, +causing an unknown variable reference (e.g., to "co"). +The operand following the @ may be any string valued expression. +The @ operator is right associative, hence the construct "@@param" is the +value of the parameter named by the value of the parameter "param". + +An expression may contain operands of datatypes bool, int, real, and string. +Mixed mode expressions are permitted with automatic type coercion. Most type +coercions from boolean or string to other datatypes are illegal. The boolean +constants "yes" and "no" are predefined and may be used within expressions. + + +2.5.2 intrinsic functions + + A number of standard intrinsic functions are recognized within expressions. +The set of functions currently supported is shown below. + + +.nf + abs acos asin atan atan2 bool cos + exp int log log10 max min mod + nint real sin sqrt str tan +.fi + + +The trigonometric functions operate in units of degrees rather than radians. +The \fImin\fR and \fImax\fR functions may have any number of arguments up +to a maximum of sixteen or so (configurable). The arguments need not all +be of the same datatype. + +A function call may take either of the following forms: + +.nf + '(' arglist ')' +or + '(' arglist ')' +.fi + +The first form is the conventional form found in all programming languages. +The second permits the generation of function names by string valued +expressions and might be useful on rare occasions. + + +2.5.3 special operands + + As noted earlier, expression operands may be constants, variables (header +fields), function calls, or references to any of the special variables. +The following special variables are recognized within expressions: + + +.nf + . A string constant, used to flag printing + $ The value of the "current field" + $F The name of the "current field" + $I The name of the "current image" + $T The current clock time (an integer value) +.fi + + +These builtin variables are especially useful for constructing context +dependent expressions. For example, the value of a field may be incremented +by 100 by assigning it the value "$ + 100". + +.ih +EXAMPLES + +1. Globally edit the database "n1", setting the value of the string parameter +"obs" to "sky" if "s-flag" is 1, to "obj" otherwise. + + cl> nhedit n1.* obs '(@"s-flag" == 1 ? "sky" : "obj")' "Observation value" + +2. Globally edit the same database, replacing the value of the parameter +"variance" by the square root of the original value. + + cl> nhedit n1.* var '(sqrt(var))' "Variance value" + +3. Replace the values of the fields A and B by the absolute value of the +original value: + + cl> nhedit n1.* a,b '(abs($))' 'Absolute value' + +4. Add a blank field with a comment after a given field (K5DX). + + cl> nhedit file.fits add_blank "INSTRUMENT DESCRIPTION " after=k5dx add+ + + Notice the use of the special field value 'add_blank' which will be +replaced by a blank keyword in the header. + +5. Add HISTORY card before a given keyword + +.nf + cl> nhedit file.fits history \ + "History text from column 9 to 80, no quotes" before=wcsdim add+ + +.fi +6. Run a command file through the first 50 extensions +.nf + + cl> for(i=1;i<51;i=i+1) { + nhedit("mymef["//i//"]",comfile="home$hh.in") + } + +.fi +7. Add a text file to the header. This will be put as HISTORY lines with +text appropriately split when long lines are encountered. Start putting the +text after the keyword KEYWN. +.nf + + cl> nhedit add_textf "mytext_file.tx" after=KEYWN add+ + + +.fi +8. Run nhedit through all the extensions in a MEF file. Assuming it is 6, then: +.nf + + cl> for(i=1;i<7;i=i+1) + nhedit("mymef.fits["//i//"]",comfi="home$myheader.txt") + +.fi +9. Run several fits files with the same set of header commands from the file +"hdrc.txt". + + cl> nhedit file*.fits commfile=hdrc.txt + +As an example the 'hdrc.txt' content can be: (Notice the 'default_pars' command) + +.nf +# +# Sample command file for nhedit task. +# +# Establish the default parameters for the rest of the commands. + +default_pars upda+ add+ show- veri- + +# Notice the use of commas if you desire. +"DETECTOR" 'Newfirm', "comment string" +ONELE 'A' "comment to A" +# +# Now delete a keyword +ONELE1 del+ show+ +add_blank " /blank keyw" + +# add a boolean value T +ONELE1 '(1==1)', "comment to A" + + "DETSIZE", '[1:2048,1:2048]' + "ENVTEM", 1.5600000000000E+01 + +# Add a field with string value 'T' +ONELEi2 'T' + +bafkeyw1 123.456 "comment to key1" before="WCSDIM" addonly+ show- +add_blank "COMMENT FOR A BLANK" after="FR-SCALE" add+ show- +history "this is a hist to append" add+ show- +history "this is a hist 22 after trim pkey" after="TRIM" add+ show- +comment "this is a comment" after="FR-SCALE" add+ show- +# END OF HDRC.TXT FILE + +.fi +.ih +SEE ALSO +hselect, hedit, mkheader, imgets, imheader +.endhelp diff --git a/pkg/images/imutil/doc/sections.hlp b/pkg/images/imutil/doc/sections.hlp new file mode 100644 index 00000000..13579b62 --- /dev/null +++ b/pkg/images/imutil/doc/sections.hlp @@ -0,0 +1,119 @@ +.help sections Dec85 images.imutil +.ih +NAME +sections -- expand an image template +.ih +USAGE +sections images +.ih +PARAMETERS +.ls images +Image template or list of images. There is no check that the names are +images and any name may be used. The thing which distinguishes an image +template from a file template is that the special characters '[' and +']' are interpreted as image sections rather than a character class +wildcard unless preceded by the escape character '!'. To explicitly +limit a wildcard template to images one should use an appropriate +extension such as ".imh". +.le +.ls option = "fullname" +The options are: +.ls "nolist" +Do not print list. +.le +.ls "fullname" +Print the full image name for each image in the template. +.le +.ls "root" +Print the root name for each image in the template. +.le +.ls "section" +Print the section for each image in the template. +.le +.le +.ls nimages +The number of images in the image template. +.le +.ih +DESCRIPTION +The image template list \fIimages\fR is expanded and the images are printed +one per line on the standard output unless the "nolist" option is given. +Other options allow selection of a portion of the image name. The number +of images in the list is determined and stored in the parameter \fInimages\fR. + +This task is used for several purposes: +.ls (1) +To verify that an image template is expanded as the user desires. +.le +.ls (2) +To create a file of image names which include image sections. +.le +.ls (3) +To create a file of new image names using the concatenation feature of the +image templates. +.le +.ls (4) +To determine the number of images specified by the user in a command language +script. +.le + +There is no check that the names are images and any name may be used. +The thing which distinguishes an \fIimage template\fR from a \fIfile +template\fR is that the special characters '[' and ']' are interpreted +as image sections rather than a character class wildcard unless +preceded by the escape character '!'. To explicitly limit a wildcard +template to images one should use an appropriate extension such as ".imh". +.ih +EXAMPLES +1. Calculate and print the number of images in a template: + +.nf + cl> sections fits*.imh opti=no + cl> = sections.nimages + cl> 7 +.fi + +2. Expand an image template: + +.nf + cl> sections fits*![3-9].imh[1:10,*] + fits003.imh[1:10,*] + fits004.imh[1:10,*] + +.fi + +Note the use of the character class escape, image section appending, +and explicit use of the .imh extension. + +3. Create a new list of image names by adding the suffix "new": + +.nf + cl> sections jan18???//new + jan18001new + jan18002new + +.fi + +Note the use of the append syntax. Also there is no guarantee that the +files are actually images. + +4. Subtract two sets of images: + +.nf + cl> sections objs*.imh[100:200,300:400] > objslist + cl> sections skys*.imh[100:200,300:400] > skyslist + cl> sections %objs%bck%* > bcklist + cl> imarith @objslist - @skyslist @bcklist +.fi + +Note the use of the substitution syntax. + +.ih +TIME REQUIREMENTS +.ih +BUGS +The image list is not sorted. +.ih +SEE ALSO +files +.endhelp diff --git a/pkg/images/imutil/hedit.par b/pkg/images/imutil/hedit.par new file mode 100644 index 00000000..660f5eea --- /dev/null +++ b/pkg/images/imutil/hedit.par @@ -0,0 +1,9 @@ +images,s,a,,,,images to be edited +fields,s,a,,,,fields to be edited +value,s,a,,,,value expression +add,b,h,no,,,add rather than edit fields +addonly,b,h,no,,,add only if field does not exist +delete,b,h,no,,,delete rather than edit fields +verify,b,h,yes,,,verify each edit operation +show,b,h,yes,,,print record of each edit operation +update,b,h,yes,,,enable updating of the image header diff --git a/pkg/images/imutil/hselect.par b/pkg/images/imutil/hselect.par new file mode 100644 index 00000000..86fcf819 --- /dev/null +++ b/pkg/images/imutil/hselect.par @@ -0,0 +1,4 @@ +images,s,a,,,,images from which selection is to be drawn +fields,s,a,,,,fields to be extracted +expr,s,a,,,,boolean expression governing selection +missing,s,h,"INDEF",,,Value for missing keywords diff --git a/pkg/images/imutil/imarith.par b/pkg/images/imutil/imarith.par new file mode 100644 index 00000000..f0ea05ae --- /dev/null +++ b/pkg/images/imutil/imarith.par @@ -0,0 +1,11 @@ +operand1,f,a,,,,Operand image or numerical constant +op,s,a,"+","+|-|*|/|min|max",,Operator +operand2,f,a,,,,Operand image or numerical constant +result,f,a,,,,Resultant image +title,s,h,"",,,Title for resultant image +divzero,r,h,0.,,,Replacement value for division by zero +hparams,s,h,"",,,List of header parameters +pixtype,s,h,"",,,Pixel type for resultant image +calctype,s,h,"",,,Calculation data type +verbose,b,h,no,,,Print operations? +noact,b,h,no,,,Print operations without performing them? diff --git a/pkg/images/imutil/imcopy.par b/pkg/images/imutil/imcopy.par new file mode 100644 index 00000000..c72e68b7 --- /dev/null +++ b/pkg/images/imutil/imcopy.par @@ -0,0 +1,6 @@ +# Task parameters for IMCOPY. + +input,s,a,,,,Input images +output,s,a,,,,Output images or directory +verbose,b,h,yes,,,Print operations performed? +mode,s,h,ql diff --git a/pkg/images/imutil/imdelete.par b/pkg/images/imutil/imdelete.par new file mode 100644 index 00000000..c9ebf99b --- /dev/null +++ b/pkg/images/imutil/imdelete.par @@ -0,0 +1,7 @@ +# Task parameters for IMDELETE. + +images,s,a,,,,List of images to be deleted +verify,b,h,no,,,Verify operation before deleting each image? +default_action,b,h,yes,,,Default delete action for verify query +go_ahead,b,q,yes,,," ?" +mode,s,h,ql diff --git a/pkg/images/imutil/imdivide.par b/pkg/images/imutil/imdivide.par new file mode 100644 index 00000000..a7521611 --- /dev/null +++ b/pkg/images/imutil/imdivide.par @@ -0,0 +1,10 @@ +# Parameters for task imdivide. + +numerator,f,a,,,,Numerator image +denominator,f,a,,,,Denominator image +resultant,f,a,,,,Resultant image +title,s,h,'*',,,Title for the resultant image +constant,r,h,0,,,Constant replacement for zero division +rescale,s,h,numerator,,,"Rescale resultant mean (norescale, mean, numerator)" +mean,s,h,1,,,Mean for rescaling +verbose,b,h,no,,,Verbose output? diff --git a/pkg/images/imutil/imexpr.par b/pkg/images/imutil/imexpr.par new file mode 100644 index 00000000..8f019d70 --- /dev/null +++ b/pkg/images/imutil/imexpr.par @@ -0,0 +1,44 @@ +# IMEXPR parameters + +expr,s,a,,,,expression +output,f,a,,,,output image +dims,s,h,auto,,,output image dimensions +intype,s,h,auto,,,minimum type for input operands +outtype,s,h,auto,,,output image pixel datatype +refim,s,h,auto,,,reference image for wcs etc +bwidth,i,h,0,0,,boundary extension width +btype,s,h,nearest,"constant|nearest|reflect|wrap|project",,\ +"boundary extension type" +bpixval,r,h,0,,,boundary pixel value +rangecheck,b,h,yes,,,perform range checking +verbose,b,h,yes,,,print informative messages +exprdb,s,h,none,,,expression database +lastout,s,h,,,,last output image + +# Input image operands. +a,s,a,,,,operand a +b,s,a,,,,operand b +c,s,a,,,,operand c +d,s,a,,,,operand d +e,s,a,,,,operand e +f,s,a,,,,operand f +g,s,a,,,,operand g +h,s,a,,,,operand h +i,s,a,,,,operand i +j,s,a,,,,operand j +k,s,a,,,,operand k +l,s,a,,,,operand l +m,s,a,,,,operand m +n,s,a,,,,operand n +o,s,a,,,,operand o +p,s,a,,,,operand p +q,s,a,,,,operand q +r,s,a,,,,operand r +s,s,a,,,,operand s +t,s,a,,,,operand t +u,s,a,,,,operand u +v,s,a,,,,operand v +w,s,a,,,,operand w +x,s,a,,,,operand x +y,s,a,,,,operand y +z,s,a,,,,operand z diff --git a/pkg/images/imutil/imfunction.par b/pkg/images/imutil/imfunction.par new file mode 100644 index 00000000..f2c56184 --- /dev/null +++ b/pkg/images/imutil/imfunction.par @@ -0,0 +1,6 @@ +# Parameter file for IMFUNCTION + +input,s,a,,,,Input images +output,s,a,,,,Output images +function,s,a,,"log10|alog10|ln|aln|sqrt|square|cbrt|cube|abs|neg|cos|sin|tan|acos|asin|atan|hcos|hsin|htan|reciprocal",,Function +verbose,b,h,yes,,,Verbose mode? diff --git a/pkg/images/imutil/imgets.par b/pkg/images/imutil/imgets.par new file mode 100644 index 00000000..92f81f62 --- /dev/null +++ b/pkg/images/imutil/imgets.par @@ -0,0 +1,3 @@ +image,s,a,,,,image name +param,s,a,,,,image parameter to be returned +value,s,h,,,,output value of image parameter diff --git a/pkg/images/imutil/imheader.par b/pkg/images/imutil/imheader.par new file mode 100644 index 00000000..f8f9cc60 --- /dev/null +++ b/pkg/images/imutil/imheader.par @@ -0,0 +1,6 @@ +# Task parameters for IMHEADER. + +images,s,a,,,,image names +imlist,s,h,"*.imh,*.fits,*.pl,*.qp,*.hhh",,,default image names +longheader,b,h,no,,,print header in multi-line format +userfields,b,h,yes,,,print the user fields (instrument parameters) diff --git a/pkg/images/imutil/imhistogram.par b/pkg/images/imutil/imhistogram.par new file mode 100644 index 00000000..12911e63 --- /dev/null +++ b/pkg/images/imutil/imhistogram.par @@ -0,0 +1,13 @@ +image,s,a,,,,Image name +z1,r,h,INDEF,,,Minimum histogram intensity +z2,r,h,INDEF,,,Maximum histogram intensity +binwidth,r,h,INDEF,,,Resolution of histogram in intensity units +nbins,i,h,512,1,,Number of bins in histogram +autoscale,b,h,yes,,,Adjust nbins and z2 for integer data? +top_closed,b,h,no,,,Include z2 in the top bin? +hist_type,s,h,"normal","normal|cumulative|difference|second_difference",,"Type of histogram" +listout,b,h,no,,,List instead of plot histogram? +plot_type,s,h,"line","line|box",,Type of vectors to plot +logy,b,h,yes,,,Log scale y-axis? +device,s,h,"stdgraph",,,output graphics device +mode,s,h,ql,,, diff --git a/pkg/images/imutil/imjoin.par b/pkg/images/imutil/imjoin.par new file mode 100644 index 00000000..3588c1bc --- /dev/null +++ b/pkg/images/imutil/imjoin.par @@ -0,0 +1,5 @@ +input,s,a,,,,"Input images" +output,s,a,,,,"Output image" +join_dimension,i,a,,1,,"Dimension to be joined" +pixtype,s,h,"",,,"Output image pixel type" +verbose,s,h,yes,,,Print messages about progress of task ? diff --git a/pkg/images/imutil/imrename.par b/pkg/images/imutil/imrename.par new file mode 100644 index 00000000..0df86d66 --- /dev/null +++ b/pkg/images/imutil/imrename.par @@ -0,0 +1,3 @@ +oldnames,s,a,,,,images to be renamed +newnames,s,a,,,,new image names +verbose,b,h,no,,,report each rename operation diff --git a/pkg/images/imutil/imreplace.par b/pkg/images/imutil/imreplace.par new file mode 100644 index 00000000..57ba5108 --- /dev/null +++ b/pkg/images/imutil/imreplace.par @@ -0,0 +1,8 @@ +# Parameters for the IMREPLACE task. + +images,s,a,,,,Images to be edited +value,r,a,,,,Replacement pixel value +imaginary,r,h,0.,,,Imaginary component for complex +lower,r,h,INDEF,,,Lower limit of replacement window +upper,r,h,INDEF,,,Upper limit of replacement window +radius,r,h,0.,,,Replacement radius diff --git a/pkg/images/imutil/imslice.par b/pkg/images/imutil/imslice.par new file mode 100644 index 00000000..02823711 --- /dev/null +++ b/pkg/images/imutil/imslice.par @@ -0,0 +1,7 @@ +# IMSLICE + +input,f,a,,,,Input images +output,f,a,,,,Output images +slice_dimension,i,a,,,,Dimension to be sliced +verbose,b,h,y,,,Verbose mode +mode,s,h,'ql' diff --git a/pkg/images/imutil/imstack.par b/pkg/images/imutil/imstack.par new file mode 100644 index 00000000..c10d2120 --- /dev/null +++ b/pkg/images/imutil/imstack.par @@ -0,0 +1,7 @@ + +# Parmeter file for IMSTACK + +images,s,a,,,,Images to be stacked +output,f,a,,,,Output image +title,s,h,'*',,,Title of output image +pixtype,s,h,'*',,,Pixel datatype of output image diff --git a/pkg/images/imutil/imstatistics.par b/pkg/images/imutil/imstatistics.par new file mode 100644 index 00000000..34702430 --- /dev/null +++ b/pkg/images/imutil/imstatistics.par @@ -0,0 +1,10 @@ +images,s,a,,,,List of input images +fields,s,h,"image,npix,mean,stddev,min,max",,,Fields to be printed +lower,r,h,INDEF,,,Lower limit for pixel values +upper,r,h,INDEF,,,Upper limit for pixel values +nclip,i,h,0,0,,Number of clipping iterations +lsigma,r,h,3.0,0,,Lower side clipping factor in sigma +usigma,r,h,3.0,0,,Upper side clipping factor in sigma +binwidth,r,h,0.1,,,Bin width of histogram in sigma +format,b,h,yes,,,Format output and print column labels ? +cache,b,h,no,,,Cache image in memory ? diff --git a/pkg/images/imutil/imsum.par b/pkg/images/imutil/imsum.par new file mode 100644 index 00000000..956ba9a0 --- /dev/null +++ b/pkg/images/imutil/imsum.par @@ -0,0 +1,10 @@ +input,s,a,,,,Input images +output,s,a,,,,Output image +title,s,h,"",,,Title for output image +hparams,s,h,"",,,List of header parameters +pixtype,s,h,"",,,Pixel datatype of output image +calctype,s,h,"",,,Calculation type +option,s,h,"sum","sum|average|median",,Output option +low_reject,r,h,0,,,Fraction or number of low pixels to reject +high_reject,r,h,0,,,Fraction or number of high pixels to reject +verbose,b,h,no,,,Print log of operation? diff --git a/pkg/images/imutil/imtile.par b/pkg/images/imutil/imtile.par new file mode 100644 index 00000000..e009d919 --- /dev/null +++ b/pkg/images/imutil/imtile.par @@ -0,0 +1,21 @@ +# IMTILE + +input,f,a,,,,List of input image tiles +output,f,a,,,,Output tiled image +nctile,i,a,,,,Number of input tiles in the output column direction +nltile,i,a,,,,Number of input tiles in the output line direction +trim_section,s,h,"[*,*]",,,Input tile section +missing_input,s,h,"",,,List of missing image tiles +start_tile,s,h,"ll",,,Position in output image of first input tile +row_order,b,h,yes,,,Insert input tiles in row order ? +raster_order,b,h,no,,,Insert input tiles in raster scan order ? +median_section,s,h,"",,,Input tile section used to compute the median +subtract,b,h,no,,,Subtract the median pixel value from each input tile ? +ncols,i,h,INDEF,,,The number of columns in the output image +nlines,i,h,INDEF,,,The number of lines in the output image +ncoverlap,i,h,-1,,,Number of columns of overlap between adjacent tiles +nloverlap,i,h,-1,,,Number of lines of overlap between adjacent tiles +opixtype,s,h,"r",,,Output image pixel type +ovalue,r,h,0.0,,,Value of undefined output image pixels +verbose,b,h,yes,,,Print messages about progress of the task ? +mode,s,h,'ql' diff --git a/pkg/images/imutil/imutil.cl b/pkg/images/imutil/imutil.cl new file mode 100644 index 00000000..c7a853a3 --- /dev/null +++ b/pkg/images/imutil/imutil.cl @@ -0,0 +1,35 @@ +#{ IMUTIL -- The Image Utilities Package. + +set imutil = "images$imutil/" + +package imutil + +# Tasks. + +task chpixtype, + hedit, + hselect, + imarith, + _imaxes, + imcopy, + imdelete, + imdivide, + imexpr, + imfunction, + imgets, + imheader, + imhistogram, + imjoin, + imrename, + imreplace, + imslice, + imstack, + imsum, + imtile, + imstatistics, + listpixels, + minmax, + nhedit, + sections = "imutil$x_images.e" + +clbye() diff --git a/pkg/images/imutil/imutil.hd b/pkg/images/imutil/imutil.hd new file mode 100644 index 00000000..59206d90 --- /dev/null +++ b/pkg/images/imutil/imutil.hd @@ -0,0 +1,31 @@ +# Help directory for the IMUTIL package + +$doc = "images$imutil/doc/" +$src = "images$imutil/src/" + +chpixtype hlp=doc$chpix.hlp, src=src$t_chpix.x +hedit hlp=doc$hedit.hlp, src=src$hedit.x +nhedit hlp=doc$nhedit.hlp, src=src$nhedit.x +hselect hlp=doc$hselect.hlp, src=src$hselect.x +imarith hlp=doc$imarith.hlp, src=src$t_imarith.x +imcopy hlp=doc$imcopy.hlp, src=src$t_imcopy.x +imdelete hlp=doc$imdelete.hlp, src=src$imdelete.x +imdivide hlp=doc$imdivide.hlp, src=src$t_imdivide.x +imexpr hlp=doc$imexpr.hlp, src=src$imexpr.gx +imfunction hlp=doc$imfunction.hlp, src=src$imfunction.x +imgets hlp=doc$imgets.hlp, src=src$imgets.x +imheader hlp=doc$imheader.hlp, src=src$imheader.x +imhistogram hlp=doc$imhistogram.hlp, src=src$imhistogram.x +imjoin hlp=doc$imjoin.hlp, src=src$t_imjoin.x +imrename hlp=doc$imrename.hlp, src=src$t_imrename.x +imreplace hlp=doc$imreplace.hlp, src=src$t_imreplace.x +imslice hlp=doc$imslice.hlp, src=src$t_imslice.x +imstack hlp=doc$imstack.hlp, src=src$t_imstack.x +imstatistics hlp=doc$imstat.hlp, src=src$t_imstat.x +imsum hlp=doc$imsum.hlp, src=src$t_imsum.x +imtile hlp=doc$imtile.hlp, src=src$t_imtile.x +listpixels hlp=doc$listpixels.hlp, src=src$listpixels.x +minmax hlp=doc$minmax.hlp, src=src$t_minmax.x +sections hlp=doc$sections.hlp, src=src$t_sections.x +revisions sys=Revisions + diff --git a/pkg/images/imutil/imutil.men b/pkg/images/imutil/imutil.men new file mode 100644 index 00000000..137bc6a8 --- /dev/null +++ b/pkg/images/imutil/imutil.men @@ -0,0 +1,25 @@ + chpixtype - Change the pixel type of a list of images + hedit - Header editor + nhedit - Edit image header using a command file + hselect - Select a subset of images satisfying a boolean expression + imarith - Simple image arithmetic + imcopy - Copy an image + imdelete - Delete a list of images + imdivide - Image division with zero checking and rescaling + imexpr - Evaluate a general image expression + imfunction - Apply a single argument function to a list of images + imgets - Return the value of an image header parameter as a string + imheader - Print an image header + imhistogram - Compute and plot or print an image histogram + imjoin - Join images along a given dimension + imrename - Rename one or more images + imreplace - Replace a range of pixel values with a constant + imslice - Slice images into images of lower dimension + imstack - Stack images into a single image of higher dimension + imsum - Compute the sum, average, or median of a set of images + imtile - Tile same sized 2D images into a 2D mosaic + imstatistics - Compute and print statistics for a list of images + listpixels - Convert an image section into a list of pixels + minmax - Compute the minimum and maximum pixel values in an image + sections - Expand an image template on the standard output + diff --git a/pkg/images/imutil/imutil.par b/pkg/images/imutil/imutil.par new file mode 100644 index 00000000..cef3f3ff --- /dev/null +++ b/pkg/images/imutil/imutil.par @@ -0,0 +1 @@ +version,s,h,"Jan97" diff --git a/pkg/images/imutil/listpixels.par b/pkg/images/imutil/listpixels.par new file mode 100644 index 00000000..a5a00d4c --- /dev/null +++ b/pkg/images/imutil/listpixels.par @@ -0,0 +1,4 @@ +images,f,a,,,,Images to be converted to list form +wcs,s,h,"logical",,,Output world coordinate system name +formats,s,h,"",,,List of pixel coordinate formats +verbose,b,h,no,,,Print banner for each input image diff --git a/pkg/images/imutil/minmax.par b/pkg/images/imutil/minmax.par new file mode 100644 index 00000000..8f87d352 --- /dev/null +++ b/pkg/images/imutil/minmax.par @@ -0,0 +1,10 @@ +images,s,a,,,,Images to be examined +force,b,h,no,,,Force recomputation of extreme values? +update,b,h,yes,,,Update the image header? +verbose,b,h,yes,,,Print computed values? +minval,r,h,INDEF,,,Minimum pixel value in image (real part) +maxval,r,h,INDEF,,,Maximum pixel value in image (real part) +iminval,r,h,INDEF,,,Minimum pixel value in image (imaginary part) +imaxval,r,h,INDEF,,,Maximum pixel value in image (imaginary part) +minpix,s,h,,,,Minimum pixel (section notation) +maxpix,s,h,,,,Maximum pixel (section notation) diff --git a/pkg/images/imutil/mkpkg b/pkg/images/imutil/mkpkg new file mode 100644 index 00000000..01b517b0 --- /dev/null +++ b/pkg/images/imutil/mkpkg @@ -0,0 +1,5 @@ +# MKPKG for the IMUTIL Package + +libpkg.a: + @src + ; diff --git a/pkg/images/imutil/nhedit.par b/pkg/images/imutil/nhedit.par new file mode 100644 index 00000000..76eab2c5 --- /dev/null +++ b/pkg/images/imutil/nhedit.par @@ -0,0 +1,14 @@ +images,s,a,,,,Images to be operated upon +fields,s,a,,,,fields to be edited +value,s,a,.,,,value expression +comment,s,a,'.',,,Keyword comment +comfile,s,h,"",,,Command file +after,s,h,"",,,keyword name to insert after +before,s,h,"",,,keyword name to insert before +update,b,h,yes,,,Update image header? +add,b,h,no,,,add rather than edit fields +addonly,b,h,no,,,add only if field does not exist +delete,b,h,no,,,delete rather than edit fields +rename,b,h,no,,,rename field names +verify,b,h,yes,,,verify each edit operation +show,b,h,yes,,,print record of each edit operation diff --git a/pkg/images/imutil/sections.par b/pkg/images/imutil/sections.par new file mode 100644 index 00000000..1f585d6c --- /dev/null +++ b/pkg/images/imutil/sections.par @@ -0,0 +1,5 @@ +# SECTIONS -- Expand an image template. + +images,s,a,,,,Image template +option,s,h,"fullname",,,"Option (nolist, fullname, root, section)" +nimages,i,h,,,,Number of images in template diff --git a/pkg/images/imutil/src/generic/imaadd.x b/pkg/images/imutil/src/generic/imaadd.x new file mode 100644 index 00000000..cd492467 --- /dev/null +++ b/pkg/images/imutil/src/generic/imaadd.x @@ -0,0 +1,255 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_adds (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call aaddks (Mems[buf[2]], a, Mems[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call aaddks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call aadds (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call aaddki (Memi[buf[2]], a, Memi[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call aaddki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call aaddi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call aaddkl (Meml[buf[2]], a, Meml[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call aaddkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call aaddl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call aaddkr (Memr[buf[2]], a, Memr[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call aaddkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call aaddr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +# IMA_ADD -- Image arithmetic addition. + +procedure ima_addd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call aaddkd (Memd[buf[2]], a, Memd[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call aaddkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call aaddd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imadiv.x b/pkg/images/imutil/src/generic/imadiv.x new file mode 100644 index 00000000..1de8b194 --- /dev/null +++ b/pkg/images/imutil/src/generic/imadiv.x @@ -0,0 +1,347 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_DIV -- Image arithmetic division. + + +procedure ima_divs (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +short a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() +short ima_efncs() +extern ima_efncs + +short divzero +common /imadcoms/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call arczs (a, Mems[buf[2]], Mems[buf[1]], len, + ima_efncs) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovks (divzero, Mems[buf[1]], len) + else if (b == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call adivks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call advzs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], + len, ima_efncs) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +short procedure ima_efncs (a) + +short a +short divzero +common /imadcoms/ divzero + +begin + return (divzero) +end + +procedure ima_divi (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +int a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() +int ima_efnci() +extern ima_efnci + +int divzero +common /imadcomi/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call arczi (a, Memi[buf[2]], Memi[buf[1]], len, + ima_efnci) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovki (divzero, Memi[buf[1]], len) + else if (b == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call adivki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call advzi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], + len, ima_efnci) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +int procedure ima_efnci (a) + +int a +int divzero +common /imadcomi/ divzero + +begin + return (divzero) +end + +procedure ima_divl (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +long a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() +long ima_efncl() +extern ima_efncl + +long divzero +common /imadcoml/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call arczl (a, Meml[buf[2]], Meml[buf[1]], len, + ima_efncl) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovkl (divzero, Meml[buf[1]], len) + else if (b == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call adivkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call advzl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], + len, ima_efncl) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +long procedure ima_efncl (a) + +long a +long divzero +common /imadcoml/ divzero + +begin + return (divzero) +end + +procedure ima_divr (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +real a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() +real ima_efncr() +extern ima_efncr + +real divzero +common /imadcomr/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call arczr (a, Memr[buf[2]], Memr[buf[1]], len, + ima_efncr) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovkr (divzero, Memr[buf[1]], len) + else if (b == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call adivkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call advzr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], + len, ima_efncr) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +real procedure ima_efncr (a) + +real a +real divzero +common /imadcomr/ divzero + +begin + return (divzero) +end + +procedure ima_divd (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +double a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() +double ima_efncd() +extern ima_efncd + +double divzero +common /imadcomd/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call arczd (a, Memd[buf[2]], Memd[buf[1]], len, + ima_efncd) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovkd (divzero, Memd[buf[1]], len) + else if (b == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call adivkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call advzd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], + len, ima_efncd) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +double procedure ima_efncd (a) + +double a +double divzero +common /imadcomd/ divzero + +begin + return (divzero) +end + diff --git a/pkg/images/imutil/src/generic/imamax.x b/pkg/images/imutil/src/generic/imamax.x new file mode 100644 index 00000000..36fec944 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamax.x @@ -0,0 +1,212 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MAX -- Image arithmetic maximum value. + + +procedure ima_maxs (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call amaxks (Mems[buf[2]], a, Mems[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) + call amaxks (Mems[buf[2]], b, Mems[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amaxs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_maxi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call amaxki (Memi[buf[2]], a, Memi[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) + call amaxki (Memi[buf[2]], b, Memi[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amaxi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_maxl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call amaxkl (Meml[buf[2]], a, Meml[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) + call amaxkl (Meml[buf[2]], b, Meml[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call amaxl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_maxr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call amaxkr (Memr[buf[2]], a, Memr[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) + call amaxkr (Memr[buf[2]], b, Memr[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call amaxr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_maxd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call amaxkd (Memd[buf[2]], a, Memd[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) + call amaxkd (Memd[buf[2]], b, Memd[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amaxd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imamin.x b/pkg/images/imutil/src/generic/imamin.x new file mode 100644 index 00000000..5124db41 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamin.x @@ -0,0 +1,212 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MIN -- Image arithmetic minimum value. + + +procedure ima_mins (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) + call aminks (Mems[buf[2]], a, Mems[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) + call aminks (Mems[buf[2]], b, Mems[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amins (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_mini (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) + call aminki (Memi[buf[2]], a, Memi[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) + call aminki (Memi[buf[2]], b, Memi[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amini (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_minl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) + call aminkl (Meml[buf[2]], a, Meml[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) + call aminkl (Meml[buf[2]], b, Meml[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call aminl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_minr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) + call aminkr (Memr[buf[2]], a, Memr[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) + call aminkr (Memr[buf[2]], b, Memr[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call aminr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_mind (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) + call aminkd (Memd[buf[2]], a, Memd[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) + call aminkd (Memd[buf[2]], b, Memd[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amind (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imamul.x b/pkg/images/imutil/src/generic/imamul.x new file mode 100644 index 00000000..05fdf8a4 --- /dev/null +++ b/pkg/images/imutil/src/generic/imamul.x @@ -0,0 +1,257 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MUL -- Image arithmetic multiplication. + + +procedure ima_muls (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call amulks (Mems[buf[2]], a, Mems[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 1) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call amulks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call amuls (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_muli (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call amulki (Memi[buf[2]], a, Memi[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 1) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call amulki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call amuli (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_mull (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call amulkl (Meml[buf[2]], a, Meml[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 1) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call amulkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call amull (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_mulr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call amulkr (Memr[buf[2]], a, Memr[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 1.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call amulkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call amulr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_muld (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call amulkd (Memd[buf[2]], a, Memd[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 1.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call amulkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call amuld (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imanl.x b/pkg/images/imutil/src/generic/imanl.x new file mode 100644 index 00000000..8ec958c4 --- /dev/null +++ b/pkg/images/imutil/src/generic/imanl.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_NL -- For each line in the output image lines from the input images +# are returned. The input images are repeated as necessary. EOF is returned +# when the last line of the output image has been reached. One dimensional +# images are read only once and the data pointers are assumed to be unchanged +# from previous calls. The image line vectors must be initialized externally +# and then left untouched. +# +# This procedure is typically used when operations upon lines or pixels +# make sense in mixed dimensioned images. For example to add a one dimensional +# image to all lines of a higher dimensional image or to subtract a +# two dimensional image from all bands of three dimensional image. +# The lengths of the common dimensions should generally be checked +# for equality with xt_imleneq. + + +int procedure ima_nls (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnls(), imgnls() + +begin + if (impnls (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnls (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnls (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nli (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnli(), imgnli() + +begin + if (impnli (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnli (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnli (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nll (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnll(), imgnll() + +begin + if (impnll (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnll (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnll (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nlr (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnlr(), imgnlr() + +begin + if (impnlr (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnlr (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnlr (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + +int procedure ima_nld (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnld(), imgnld() + +begin + if (impnld (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnld (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnld (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end + diff --git a/pkg/images/imutil/src/generic/imasub.x b/pkg/images/imutil/src/generic/imasub.x new file mode 100644 index 00000000..1a0fcb2c --- /dev/null +++ b/pkg/images/imutil/src/generic/imasub.x @@ -0,0 +1,252 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_SUB -- Image arithmetic subtraction. + + +procedure ima_subs (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +short a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nls() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nls (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubks (Mems[buf[2]], a, Mems[buf[1]], len) + call anegs (Mems[buf[1]], Mems[buf[1]], len) + } else + call anegs (Mems[buf[2]], Mems[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nls (im, buf, v, 2) != EOF) { + if (b == 0) + call amovs (Mems[buf[2]], Mems[buf[1]], len) + else + call asubks (Mems[buf[2]], b, Mems[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nls (im, buf, v, 3) != EOF) + call asubs (Mems[buf[2]], Mems[buf[3]], Mems[buf[1]], len) + } +end + +procedure ima_subi (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +int a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nli() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nli (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubki (Memi[buf[2]], a, Memi[buf[1]], len) + call anegi (Memi[buf[1]], Memi[buf[1]], len) + } else + call anegi (Memi[buf[2]], Memi[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nli (im, buf, v, 2) != EOF) { + if (b == 0) + call amovi (Memi[buf[2]], Memi[buf[1]], len) + else + call asubki (Memi[buf[2]], b, Memi[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nli (im, buf, v, 3) != EOF) + call asubi (Memi[buf[2]], Memi[buf[3]], Memi[buf[1]], len) + } +end + +procedure ima_subl (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +long a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nll() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nll (im, buf, v, 2) != EOF) { + if (a != 0) { + call asubkl (Meml[buf[2]], a, Meml[buf[1]], len) + call anegl (Meml[buf[1]], Meml[buf[1]], len) + } else + call anegl (Meml[buf[2]], Meml[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nll (im, buf, v, 2) != EOF) { + if (b == 0) + call amovl (Meml[buf[2]], Meml[buf[1]], len) + else + call asubkl (Meml[buf[2]], b, Meml[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nll (im, buf, v, 3) != EOF) + call asubl (Meml[buf[2]], Meml[buf[3]], Meml[buf[1]], len) + } +end + +procedure ima_subr (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +real a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nlr() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nlr (im, buf, v, 2) != EOF) { + if (a != 0.0) { + call asubkr (Memr[buf[2]], a, Memr[buf[1]], len) + call anegr (Memr[buf[1]], Memr[buf[1]], len) + } else + call anegr (Memr[buf[2]], Memr[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nlr (im, buf, v, 2) != EOF) { + if (b == 0.0) + call amovr (Memr[buf[2]], Memr[buf[1]], len) + else + call asubkr (Memr[buf[2]], b, Memr[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nlr (im, buf, v, 3) != EOF) + call asubr (Memr[buf[2]], Memr[buf[3]], Memr[buf[1]], len) + } +end + +procedure ima_subd (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +double a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nld() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nld (im, buf, v, 2) != EOF) { + if (a != 0.0D0) { + call asubkd (Memd[buf[2]], a, Memd[buf[1]], len) + call anegd (Memd[buf[1]], Memd[buf[1]], len) + } else + call anegd (Memd[buf[2]], Memd[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nld (im, buf, v, 2) != EOF) { + if (b == 0.0D0) + call amovd (Memd[buf[2]], Memd[buf[1]], len) + else + call asubkd (Memd[buf[2]], b, Memd[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nld (im, buf, v, 3) != EOF) + call asubd (Memd[buf[2]], Memd[buf[3]], Memd[buf[1]], len) + } +end + diff --git a/pkg/images/imutil/src/generic/imfuncs.x b/pkg/images/imutil/src/generic/imfuncs.x new file mode 100644 index 00000000..67bc4ed5 --- /dev/null +++ b/pkg/images/imutil/src/generic/imfuncs.x @@ -0,0 +1,1613 @@ +include +include +include + + + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10r (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_elogr() +extern if_elogr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call alogr (Memr[buf1], Memr[buf2], npix, if_elogr) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +real procedure if_elogr (x) + +real x # the input pixel value + +begin + return (real(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10r (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_va10r (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10r (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of points + +int i +real maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0.0 + else + b[i] = 10.0 ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_lnr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +real if_elnr() +extern if_elnr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call allnr (Memr[buf1], Memr[buf2], npix, if_elnr) +end + + +# IF_ELN -- The error function for the natural logarithm. + +real procedure if_elnr (x) + +real x # input value + +begin + return (real (LN_10) * real(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_alnr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_valnr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valnr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval, eval + +begin + maxexp = log (10.0 ** real (MAX_EXPONENT)) + maxval = MAX_REAL + eval = real (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0.0 + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqrr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_esqrr() +extern if_esqrr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call asqrr (Memr[buf1], Memr[buf2], npix, if_esqrr) +end + + +# IF_ESQR -- Error function for the square root. + +real procedure if_esqrr (x) + +real x # input value + +begin + return (0.0) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_squarer (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call apowkr (Memr[buf1], 2, Memr[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrtr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vcbrtr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrtr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real onethird + +begin + onethird = 1.0 / 3.0 + do i = 1, n { + if (a[i] >= 0.0) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cuber (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call apowkr (Memr[buf1], 3, Memr[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vcosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vsinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsinr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vtanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtanr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vacosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1.0) + b[i] = acos (1.0) + else if (a[i] < -1.0) + b[i] = acos (-1.0) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vasinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasinr (a, b, n) + +real a[n] +real b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1.0) + b[i] = asin (1.0) + else if (a[i] < -1.0) + b[i] = asin (-1.0) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vatanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatanr (a, b, n) + +real a[n] +real b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcosr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhcosr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcosr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval + +begin + maxexp = log (10.0 ** real(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsinr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhsinr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsinr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i +real maxexp, maxval + +begin + maxexp = log (10.0 ** real(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htanr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call if_vhtanr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtanr (a, b, n) + +real a[n] # the input vector +real b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recipr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +real if_erecipr() +extern if_erecipr() +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call arczr (1.0, Memr[buf1], Memr[buf2], npix, if_erecipr) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +real procedure if_erecipr (x) + +real x + +begin + return (0.0) +end + + + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10d (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_elogd() +extern if_elogd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call alogd (Memd[buf1], Memd[buf2], npix, if_elogd) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +double procedure if_elogd (x) + +double x # the input pixel value + +begin + return (double(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10d (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_va10d (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10d (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of points + +int i +double maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0.0D0 + else + b[i] = 10.0D0 ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_lnd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +double if_elnd() +extern if_elnd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call allnd (Memd[buf1], Memd[buf2], npix, if_elnd) +end + + +# IF_ELN -- The error function for the natural logarithm. + +double procedure if_elnd (x) + +double x # input value + +begin + return (double (LN_10) * double(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_alnd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_valnd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valnd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval, eval + +begin + maxexp = log (10.0D0 ** double (MAX_EXPONENT)) + maxval = MAX_REAL + eval = double (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0.0D0 + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqrd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_esqrd() +extern if_esqrd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call asqrd (Memd[buf1], Memd[buf2], npix, if_esqrd) +end + + +# IF_ESQR -- Error function for the square root. + +double procedure if_esqrd (x) + +double x # input value + +begin + return (0.0D0) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_squared (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call apowkd (Memd[buf1], 2, Memd[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrtd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vcbrtd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrtd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double onethird + +begin + onethird = 1.0D0 / 3.0D0 + do i = 1, n { + if (a[i] >= 0.0D0) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cubed (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call apowkd (Memd[buf1], 3, Memd[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vcosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vsind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsind (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vtand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtand (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vacosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1.0D0) + b[i] = acos (1.0D0) + else if (a[i] < -1.0D0) + b[i] = acos (-1.0D0) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vasind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasind (a, b, n) + +double a[n] +double b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1.0D0) + b[i] = asin (1.0D0) + else if (a[i] < -1.0D0) + b[i] = asin (-1.0D0) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vatand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatand (a, b, n) + +double a[n] +double b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcosd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhcosd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcosd (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval + +begin + maxexp = log (10.0D0 ** double(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsind (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhsind (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsind (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i +double maxexp, maxval + +begin + maxexp = log (10.0D0 ** double(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htand (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call if_vhtand (Memd[buf1], Memd[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtand (a, b, n) + +double a[n] # the input vector +double b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recipd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +double if_erecipd() +extern if_erecipd() +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call arczd (1.0, Memd[buf1], Memd[buf2], npix, if_erecipd) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +double procedure if_erecipd (x) + +double x + +begin + return (0.0D0) +end + + + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absl (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnll(), impnll() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnll (im1, buf1, v1) != EOF) && + (impnll (im2, buf2, v2) != EOF)) + call aabsl (Meml[buf1], Meml[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negl (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnll(), impnll() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnll (im1, buf1, v1) != EOF) && + (impnll (im2, buf2, v2) != EOF)) + call anegl (Meml[buf1], Meml[buf2], npix) +end + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call aabsr (Memr[buf1], Memr[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negr (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnlr(), impnlr() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnlr (im1, buf1, v1) != EOF) && + (impnlr (im2, buf2, v2) != EOF)) + call anegr (Memr[buf1], Memr[buf2], npix) +end + + + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_absd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call aabsd (Memd[buf1], Memd[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_negd (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnld(), impnld() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnld (im1, buf1, v1) != EOF) && + (impnld (im2, buf2, v2) != EOF)) + call anegd (Memd[buf1], Memd[buf2], npix) +end + + diff --git a/pkg/images/imutil/src/generic/imjoin.x b/pkg/images/imutil/src/generic/imjoin.x new file mode 100644 index 00000000..83b02541 --- /dev/null +++ b/pkg/images/imutil/src/generic/imjoin.x @@ -0,0 +1,527 @@ +include + +define VPTR Memi[$1+$2-1] # Array of axis vector pointers + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoins (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnls() +pointer impnls() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnls (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnls (out, outbuf, Meml[vout]) + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnls (out, outbuf, Meml[vout]) + stat = imgnls (in, inbuf, Meml[VPTR(vin,image)]) + call amovs (Mems[inbuf], Mems[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoini (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnli() +pointer impnli() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnli (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnli (out, outbuf, Meml[vout]) + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnli (out, outbuf, Meml[vout]) + stat = imgnli (in, inbuf, Meml[VPTR(vin,image)]) + call amovi (Memi[inbuf], Memi[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinl (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnll() +pointer impnll() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnll (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnll (out, outbuf, Meml[vout]) + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnll (out, outbuf, Meml[vout]) + stat = imgnll (in, inbuf, Meml[VPTR(vin,image)]) + call amovl (Meml[inbuf], Meml[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinr (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnlr() +pointer impnlr() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnlr (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnlr (out, outbuf, Meml[vout]) + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnlr (out, outbuf, Meml[vout]) + stat = imgnlr (in, inbuf, Meml[VPTR(vin,image)]) + call amovr (Memr[inbuf], Memr[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoind (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnld() +pointer impnld() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnld (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnld (out, outbuf, Meml[vout]) + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnld (out, outbuf, Meml[vout]) + stat = imgnld (in, inbuf, Meml[VPTR(vin,image)]) + call amovd (Memd[inbuf], Memd[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoinx (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnlx() +pointer impnlx() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnlx (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnlx (out, outbuf, Meml[vout]) + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnlx (out, outbuf, Meml[vout]) + stat = imgnlx (in, inbuf, Meml[VPTR(vin,image)]) + call amovx (Memx[inbuf], Memx[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + + diff --git a/pkg/images/imutil/src/generic/imrep.x b/pkg/images/imutil/src/generic/imrep.x new file mode 100644 index 00000000..bcc29d0a --- /dev/null +++ b/pkg/images/imutil/src/generic/imrep.x @@ -0,0 +1,1423 @@ +include +include + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imreps (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +short floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnls(), impnls() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnls (im, buf2, v2) != EOF) + call amovks (newval, Mems[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call arles (Mems[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call arges (Mems[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnls (im, buf1, v1) != EOF) { + junk = impnls (im, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + call areps (Mems[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrreps (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +short floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnls(), impnls() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnls (im, buf2, v2) != EOF) + call amovks (newval, Mems[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_SHORT + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_SHORT + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_SHORT) + + while (imgnls (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Mems[buf1] + val2 = Mems[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Mems[ptr+l] = INDEFS + } + } + } else { + if (!IS_INDEFS(val2)) + Mems[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnls (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Mems[buf1] + if (IS_INDEFS(Mems[buf1])) + Mems[buf2] = newval + else + Mems[buf2] = val1 + Mems[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_SHORT) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure areps (a, npts, floor, ceil, newval) + +short a[npts] # Input arrays +int npts # Number of points +short floor, ceil # Replacement limits +short newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arles (a, npts, floor, newval) + +short a[npts] +int npts +short floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arges (a, npts, ceil, newval) + +short a[npts] +int npts +short ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepi (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +int floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnli(), impnli() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnli (im, buf2, v2) != EOF) + call amovki (newval, Memi[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call arlei (Memi[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call argei (Memi[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnli (im, buf1, v1) != EOF) { + junk = impnli (im, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + call arepi (Memi[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepi (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +int floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnli(), impnli() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnli (im, buf2, v2) != EOF) + call amovki (newval, Memi[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_INT + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_INT + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_INT) + + while (imgnli (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memi[buf1] + val2 = Memi[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memi[ptr+l] = INDEFI + } + } + } else { + if (!IS_INDEFI(val2)) + Memi[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnli (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memi[buf1] + if (IS_INDEFI(Memi[buf1])) + Memi[buf2] = newval + else + Memi[buf2] = val1 + Memi[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_INT) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepi (a, npts, floor, ceil, newval) + +int a[npts] # Input arrays +int npts # Number of points +int floor, ceil # Replacement limits +int newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlei (a, npts, floor, newval) + +int a[npts] +int npts +int floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argei (a, npts, ceil, newval) + +int a[npts] +int npts +int ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepl (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real ilower +long floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnll(), impnll() + +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnll (im, buf2, v2) != EOF) + call amovkl (newval, Meml[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = int (upper) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call arlel (Meml[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call argel (Meml[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + while (imgnll (im, buf1, v1) != EOF) { + junk = impnll (im, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + call arepl (Meml[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepl (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real ilower +long floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnll(), impnll() +bool fp_equalr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnll (im, buf2, v2) != EOF) + call amovkl (newval, Meml[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_LONG + ceil = int (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_LONG + + # Replace pixels between lower and upper by value. + } else { + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_LONG) + + while (imgnll (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Meml[buf1] + val2 = Meml[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Meml[ptr+l] = INDEFL + } + } + } else { + if (!IS_INDEFL(val2)) + Meml[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnll (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Meml[buf1] + if (IS_INDEFL(Meml[buf1])) + Meml[buf2] = newval + else + Meml[buf2] = val1 + Meml[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_LONG) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepl (a, npts, floor, ceil, newval) + +long a[npts] # Input arrays +int npts # Number of points +long floor, ceil # Replacement limits +long newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlel (a, npts, floor, newval) + +long a[npts] +int npts +long floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argel (a, npts, ceil, newval) + +long a[npts] +int npts +long ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepr (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +real floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlr(), impnlr() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlr (im, buf2, v2) != EOF) + call amovkr (newval, Memr[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arler (Memr[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arger (Memr[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnlr (im, buf1, v1) != EOF) { + junk = impnlr (im, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + call arepr (Memr[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepr (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +real floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnlr(), impnlr() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlr (im, buf2, v2) != EOF) + call amovkr (newval, Memr[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_REAL + ceil = double (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + ceil = MAX_REAL + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_REAL) + + while (imgnlr (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memr[buf1] + val2 = Memr[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memr[ptr+l] = INDEFR + } + } + } else { + if (!IS_INDEFR(val2)) + Memr[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnlr (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memr[buf1] + if (IS_INDEFR(Memr[buf1])) + Memr[buf2] = newval + else + Memr[buf2] = val1 + Memr[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_REAL) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepr (a, npts, floor, ceil, newval) + +real a[npts] # Input arrays +int npts # Number of points +real floor, ceil # Replacement limits +real newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arler (a, npts, floor, newval) + +real a[npts] +int npts +real floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arger (a, npts, ceil, newval) + +real a[npts] +int npts +real ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepd (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +double floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnld(), impnld() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnld (im, buf2, v2) != EOF) + call amovkd (newval, Memd[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arled (Memd[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arged (Memd[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnld (im, buf1, v1) != EOF) { + junk = impnld (im, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + call arepd (Memd[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepd (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +double floor, ceil, newval, val1, val2 +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnld(), impnld() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = double (value) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnld (im, buf2, v2) != EOF) + call amovkd (newval, Memd[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = -MAX_DOUBLE + ceil = double (upper) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + ceil = MAX_DOUBLE + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_DOUBLE) + + while (imgnld (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memd[buf1] + val2 = Memd[buf2] + if ((val1 >= floor) && (val1 <= ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memd[ptr+l] = INDEFD + } + } + } else { + if (!IS_INDEFD(val2)) + Memd[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnld (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memd[buf1] + if (IS_INDEFD(Memd[buf1])) + Memd[buf2] = newval + else + Memd[buf2] = val1 + Memd[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_DOUBLE) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepd (a, npts, floor, ceil, newval) + +double a[npts] # Input arrays +int npts # Number of points +double floor, ceil # Replacement limits +double newval # Replacement value + +int i + +begin + + do i = 1, npts { + if ((a[i] >= floor) && (a[i] <= ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arled (a, npts, floor, newval) + +double a[npts] +int npts +double floor, newval + +int i + +begin + + do i = 1, npts + if (a[i] <= floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arged (a, npts, ceil, newval) + +double a[npts] +int npts +double ceil, newval + +int i + +begin + + do i = 1, npts + if (a[i] >= ceil) + a[i] = newval +end + + + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrepx (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +complex floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnlx(), impnlx() + + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + newval = complex (value, img) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlx (im, buf2, v2) != EOF) + call amovkx (newval, Memx[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + ceil = double (upper) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call arlex (Memx[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = double (lower) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call argex (Memx[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + floor = double (lower) + ceil = double (upper) + while (imgnlx (im, buf1, v1) != EOF) { + junk = impnlx (im, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + call arepx (Memx[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrepx (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +complex floor, ceil, newval, val1, val2 +real abs_floor, abs_ceil +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnlx(), impnlx() + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + newval = complex (value, img) + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnlx (im, buf2, v2) != EOF) + call amovkx (newval, Memx[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + floor = 0 + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + floor = real (lower) + ceil = MAX_REAL + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + # Replace pixels between lower and upper by value. + } else { + floor = real (lower) + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_COMPLEX) + + while (imgnlx (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Memx[buf1] + val2 = Memx[buf2] + if ((abs (val1) >= abs_floor) && (abs (val1) <= abs_ceil)) { + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Memx[ptr+l] = INDEFX + } + } + } else { + if (!IS_INDEFX(val2)) + Memx[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnlx (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Memx[buf1] + if (IS_INDEFX(Memx[buf1])) + Memx[buf2] = newval + else + Memx[buf2] = val1 + Memx[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_COMPLEX) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arepx (a, npts, floor, ceil, newval) + +complex a[npts] # Input arrays +int npts # Number of points +complex floor, ceil # Replacement limits +complex newval # Replacement value + +int i +real abs_floor +real abs_ceil + +begin + abs_floor = abs (floor) + abs_ceil = abs (ceil) + + do i = 1, npts { + if ((abs (a[i]) >= abs_floor) && (abs (a[i]) <= abs_ceil)) + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arlex (a, npts, floor, newval) + +complex a[npts] +int npts +complex floor, newval + +int i +real abs_floor + +begin + abs_floor = abs (floor) + + do i = 1, npts + if (abs (a[i]) <= abs_floor) + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure argex (a, npts, ceil, newval) + +complex a[npts] +int npts +complex ceil, newval + +int i +real abs_ceil + +begin + abs_ceil = abs (ceil) + + do i = 1, npts + if (abs (a[i]) >= abs_ceil) + a[i] = newval +end + + diff --git a/pkg/images/imutil/src/generic/imsum.x b/pkg/images/imutil/src/generic/imsum.x new file mode 100644 index 00000000..fcb43716 --- /dev/null +++ b/pkg/images/imutil/src/generic/imsum.x @@ -0,0 +1,1902 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../imsum.h" + +define TMINSW 1.00 # Relative timings for nvecs = 5 +define TMXMNSW 1.46 +define TMED3 0.18 +define TMED5 0.55 + +# IMSUM -- Sum or average images with optional high and low pixel rejection. +# +# This procedure has to be clever in not exceeding the maximum number of images +# which can be mapped at one time. If no pixels are being rejected then the +# images can be summed (or averaged) in blocks using the output image to hold +# intermediate results. If pixels are being rejected then lines from all +# images must be obtained. If the number of images exceeds the maximum +# then only a subset of the images are kept mapped and the remainder are +# mapped and unmapped for each line. This, of course, is inefficient but +# there is no other way. + + +procedure imsums (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +short const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnls(), impnls() +errchk immap, imunmap, imgnls, impnls + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnls (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrs (Mems[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aadds (Mems[buf_in], Mems[buf_out], + Mems[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivks (Mems[buf_out], const, Mems[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_SHORT) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnls (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnls (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovs (Mems[buf_in], Mems[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejs (Memi[buf], nimages, Mems[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivks (Mems[buf_out], const, Mems[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejs (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +short b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovs (Mems[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minsws (a, i, npts) + i = i - 1 + } + call amovs (Mems[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxsws (a, i, npts) + i = i - 1 + } + call amovs (Mems[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnsws (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minsws (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxsws (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovs (Mems[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadds (Mems[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3s (Mems[a[1]], Mems[a[2]], Mems[a[3]], b, npts) + } else { + call amed5s (Mems[a[1]], Mems[a[2]], Mems[a[3]], + Mems[a[4]], Mems[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +short temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] < Mems[kmin]) + kmin = k + } + if (k != kmin) { + temp = Mems[k] + Mems[k] = Mems[kmin] + Mems[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +short temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] > Mems[kmax]) + kmax = k + } + if (k != kmax) { + temp = Mems[k] + Mems[k] = Mems[kmax] + Mems[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnsws (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +short temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Mems[k] > Mems[kmax]) + kmax = k + else if (Mems[k] < Mems[kmin]) + kmin = k + } + temp = Mems[k] + Mems[k] = Mems[kmax] + Mems[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Mems[j] + Mems[j] = Mems[kmax] + Mems[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Mems[j] + Mems[j] = Mems[kmin] + Mems[kmin] = temp + } + } +end + +procedure imsumi (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +int const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnli(), impnli() +errchk immap, imunmap, imgnli, impnli + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnli (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclri (Memi[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddi (Memi[buf_in], Memi[buf_out], + Memi[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivki (Memi[buf_out], const, Memi[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_INT) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnli (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnli (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovi (Memi[buf_in], Memi[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imreji (Memi[buf], nimages, Memi[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivki (Memi[buf_out], const, Memi[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imreji (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +int b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovi (Memi[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswi (a, i, npts) + i = i - 1 + } + call amovi (Memi[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswi (a, i, npts) + i = i - 1 + } + call amovi (Memi[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswi (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswi (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswi (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovi (Memi[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddi (Memi[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3i (Memi[a[1]], Memi[a[2]], Memi[a[3]], b, npts) + } else { + call amed5i (Memi[a[1]], Memi[a[2]], Memi[a[3]], + Memi[a[4]], Memi[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +int temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] < Memi[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memi[k] + Memi[k] = Memi[kmin] + Memi[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +int temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] > Memi[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memi[k] + Memi[k] = Memi[kmax] + Memi[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswi (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +int temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memi[k] > Memi[kmax]) + kmax = k + else if (Memi[k] < Memi[kmin]) + kmin = k + } + temp = Memi[k] + Memi[k] = Memi[kmax] + Memi[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memi[j] + Memi[j] = Memi[kmax] + Memi[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memi[j] + Memi[j] = Memi[kmin] + Memi[kmin] = temp + } + } +end + +procedure imsuml (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +long const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnll(), impnll() +errchk immap, imunmap, imgnll, impnll + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnll (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrl (Meml[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddl (Meml[buf_in], Meml[buf_out], + Meml[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkl (Meml[buf_out], const, Meml[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnll (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnll (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovl (Meml[buf_in], Meml[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejl (Memi[buf], nimages, Meml[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkl (Meml[buf_out], const, Meml[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejl (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +long b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovl (Meml[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswl (a, i, npts) + i = i - 1 + } + call amovl (Meml[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswl (a, i, npts) + i = i - 1 + } + call amovl (Meml[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswl (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswl (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswl (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovl (Meml[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddl (Meml[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3l (Meml[a[1]], Meml[a[2]], Meml[a[3]], b, npts) + } else { + call amed5l (Meml[a[1]], Meml[a[2]], Meml[a[3]], + Meml[a[4]], Meml[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +long temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] < Meml[kmin]) + kmin = k + } + if (k != kmin) { + temp = Meml[k] + Meml[k] = Meml[kmin] + Meml[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +long temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] > Meml[kmax]) + kmax = k + } + if (k != kmax) { + temp = Meml[k] + Meml[k] = Meml[kmax] + Meml[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswl (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +long temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Meml[k] > Meml[kmax]) + kmax = k + else if (Meml[k] < Meml[kmin]) + kmin = k + } + temp = Meml[k] + Meml[k] = Meml[kmax] + Meml[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Meml[j] + Meml[j] = Meml[kmax] + Meml[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Meml[j] + Meml[j] = Meml[kmin] + Meml[kmin] = temp + } + } +end + +procedure imsumr (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +real const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnlr(), impnlr() +errchk immap, imunmap, imgnlr, impnlr + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnlr (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrr (Memr[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddr (Memr[buf_in], Memr[buf_out], + Memr[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkr (Memr[buf_out], const, Memr[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_REAL) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnlr (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnlr (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovr (Memr[buf_in], Memr[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejr (Memi[buf], nimages, Memr[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkr (Memr[buf_out], const, Memr[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejr (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +real b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovr (Memr[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswr (a, i, npts) + i = i - 1 + } + call amovr (Memr[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswr (a, i, npts) + i = i - 1 + } + call amovr (Memr[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswr (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswr (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswr (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovr (Memr[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddr (Memr[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3r (Memr[a[1]], Memr[a[2]], Memr[a[3]], b, npts) + } else { + call amed5r (Memr[a[1]], Memr[a[2]], Memr[a[3]], + Memr[a[4]], Memr[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +real temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] < Memr[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memr[k] + Memr[k] = Memr[kmin] + Memr[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +real temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] > Memr[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memr[k] + Memr[k] = Memr[kmax] + Memr[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswr (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +real temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memr[k] > Memr[kmax]) + kmax = k + else if (Memr[k] < Memr[kmin]) + kmin = k + } + temp = Memr[k] + Memr[k] = Memr[kmax] + Memr[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memr[j] + Memr[j] = Memr[kmax] + Memr[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memr[j] + Memr[j] = Memr[kmin] + Memr[kmin] = temp + } + } +end + +procedure imsumd (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +double const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnld(), impnld() +errchk immap, imunmap, imgnld, impnld + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnld (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclrd (Memd[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aaddd (Memd[buf_in], Memd[buf_out], + Memd[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivkd (Memd[buf_out], const, Memd[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_DOUBLE) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnld (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnld (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amovd (Memd[buf_in], Memd[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrejd (Memi[buf], nimages, Memd[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivkd (Memd[buf_out], const, Memd[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrejd (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +double b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amovd (Memd[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minswd (a, i, npts) + i = i - 1 + } + call amovd (Memd[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxswd (a, i, npts) + i = i - 1 + } + call amovd (Memd[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnswd (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minswd (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxswd (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amovd (Memd[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aaddd (Memd[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3d (Memd[a[1]], Memd[a[2]], Memd[a[3]], b, npts) + } else { + call amed5d (Memd[a[1]], Memd[a[2]], Memd[a[3]], + Memd[a[4]], Memd[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +double temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] < Memd[kmin]) + kmin = k + } + if (k != kmin) { + temp = Memd[k] + Memd[k] = Memd[kmin] + Memd[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +double temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] > Memd[kmax]) + kmax = k + } + if (k != kmax) { + temp = Memd[k] + Memd[k] = Memd[kmax] + Memd[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnswd (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +double temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Memd[k] > Memd[kmax]) + kmax = k + else if (Memd[k] < Memd[kmin]) + kmin = k + } + temp = Memd[k] + Memd[k] = Memd[kmax] + Memd[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Memd[j] + Memd[j] = Memd[kmax] + Memd[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Memd[j] + Memd[j] = Memd[kmin] + Memd[kmin] = temp + } + } +end + diff --git a/pkg/images/imutil/src/generic/mkpkg b/pkg/images/imutil/src/generic/mkpkg new file mode 100644 index 00000000..9878bc7b --- /dev/null +++ b/pkg/images/imutil/src/generic/mkpkg @@ -0,0 +1,21 @@ +# Make IMUTIL. + +$checkout libpkg.a ../../../ +$update libpkg.a +$checkin libpkg.a ../../../ +$exit + +libpkg.a: + imaadd.x + imadiv.x + imamax.x + imamin.x + imamul.x + imanl.x + imasub.x + imfuncs.x + imjoin.x + imrep.x + imsum.x ../imsum.h + ; + diff --git a/pkg/images/imutil/src/getcmd.x b/pkg/images/imutil/src/getcmd.x new file mode 100644 index 00000000..2ed08314 --- /dev/null +++ b/pkg/images/imutil/src/getcmd.x @@ -0,0 +1,406 @@ +include +include +include +include + +# parameter names and values. + +define HS_ADD 1 +define HS_ADDONLY 2 +define HS_UPDATE 3 +define HS_VERIFY 4 +define HS_SHOW 5 +define HS_DELETE 6 +define HS_RENAME 7 +define HS_FIELD 8 +define HS_VALUE 9 +define HS_COMMENT 10 +define HS_BEFORE 11 +define HS_AFTER 12 +define ERROR -2 + +define HADD Memi[$1] +define HADDONLY Memi[$1+1] +define HUPDATE Memi[$1+2] +define HVERIFY Memi[$1+3] +define HSHOW Memi[$1+4] +define HDELETE Memi[$1+5] +define HRENAME Memi[$1+6] +define HBAF Memi[$1+7] +define HFIELD Memc[P2C($1+10)] +define HVALUE Memc[P2C($1+46)] +define HCOMMENT Memc[P2C($1+86)] +define HBAFVALUE Memc[P2C($1+126)] + +define HSZ 200 + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 +define OP_DEFPAR 5 +define OP_RENAME 6 +define BEFORE 1 +define AFTER 2 + +define LEN_CARD 80 + +# HE_CMDPARS -- Procedure to parse and analyze a string of the form: +# + +procedure he_getcmdf (cmd, operation, fields, valexpr, comment, pkey, baf, + update, verify, show) + + +char cmd[ARB] #I String with kernel section +int operation +char fields[ARB] +char valexpr[ARB] +char comment[ARB] +char pkey[ARB] +int baf +int update +int verify +int show + +pointer hc +char outstr[LEN_CARD] +char identif[LEN_CARD], dot +int ip, nexpr, token, add, addonly, delete, rename, nch +bool streq() +int lex_type, ctotok(), he_ks_lex(), ctowrd() +errchk syserr, syserrs + +begin + # The default values should have been already initialized + # with a call fxf_ksinit(). + + call calloc(hc, HSZ, TY_STRUCT) + call he_ksinit (hc) + + ip = 1 + nexpr = 0 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + if (ip == 1) { + nch= ctowrd(cmd, ip, outstr, LEN_CARD) + token = TOK_IDENTIFIER + } else { + token = ctotok (cmd, ip, outstr, LEN_CARD) + } + + if (token == TOK_CHARCON) { + ip = ip - 2 + nch= ctowrd(cmd, ip, outstr, LEN_CARD) + if (nexpr >= 1) + token = TOK_STRING + if (nch <=3) { + #ctowrd will not parse one letter string, doit in here. + outstr[1]=cmd[ip-2] + outstr[2]=EOS + } + } + + if (token == TOK_STRING && nexpr == 0) + token = TOK_IDENTIFIER + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + + case TOK_NUMBER: + if (nexpr != 1) { + call eprintf ("%s\n") + call pargstr (cmd) + call error (13,"Numeric value not allow in this field") + } + call strcpy (outstr, HVALUE(hc), LEN_CARD) + nexpr = nexpr + 1 + case TOK_CHARCON: + ip = ip - 1 + case TOK_STRING: + if (nexpr != 1 && nexpr != 2) { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13, "Value or comment error") + } + if (nexpr == 1) + call strcpy (outstr, HVALUE(hc), LEN_CARD) + if (nexpr == 2) + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + nexpr = nexpr + 1 + + case TOK_IDENTIFIER: + call strcpy (outstr, identif, LEN_CARD) + call strlwr (outstr) + lex_type = he_ks_lex (outstr) + + if (streq(identif, "comment") && nexpr == 0) + lex_type = 0 + # look for =, + or - + if (lex_type > 0) { + call he_ks_gvalue (lex_type, cmd, ip, hc) + } else { + #if (nexpr == 0 || nexpr == 1) + if (nexpr == 0) + call strcpy (identif, HFIELD(hc), LEN_CARD) + else if (nexpr == 1) + call strcpy (outstr, HVALUE(hc), LEN_CARD) + else { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13, "Field or value error") + } + } + nexpr = nexpr + 1 + + case TOK_OPERATOR: + dot = outstr[1] + if (nexpr == 1 && dot == '.') + call strcpy (outstr, HVALUE(hc), LEN_CARD) + else if (nexpr == 2 && dot == '.') + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + else { + call eprintf ("%s\n") + call pargstr (cmd) + call error(13,"error in tok_operator value") + } + nexpr = nexpr + 1 + + default: + #call error(13,"error in command line") + } + } + + call strcpy (HFIELD(hc), fields, LEN_CARD) + call strcpy (HVALUE(hc), valexpr, LEN_CARD) + call strcpy (HCOMMENT(hc), comment, LEN_CARD) + call strcpy (HBAFVALUE(hc), pkey, LEN_CARD) + baf = HBAF(hc) + add = HADD(hc) + addonly = HADDONLY(hc) + update = HUPDATE(hc) + verify = HVERIFY(hc) + show = HSHOW(hc) + delete = HDELETE(hc) + rename = HRENAME(hc) + + operation = OP_EDIT + if (add == -1 && addonly == -1 && delete == -1 && rename == -1) + operation = OP_DEFPAR + else if (add == YES) + operation = OP_ADD + else if (addonly == YES) + operation = OP_INIT + else if (delete == YES) + operation = OP_DELETE + else if (rename == YES) + operation = OP_RENAME + + if (streq (fields, "default_pars")) + operation = -operation + + call mfree(hc, TY_STRUCT) +end + + +# HE_KS_LEX -- Map an identifier into a header parameter code. + +int procedure he_ks_lex (outstr) + +char outstr[ARB] + +int len, strlen(), strncmp() +errchk syserr, syserrs + +begin + len = strlen (outstr) + + # Allow for small string to be taken as keyword names + # and not hedit parameters, like 'up' instead of 'up(date)'. + if (len < 3) + return(0) + + # Other kernel keywords. + if (strncmp (outstr, "field", len) == 0) + return (HS_FIELD) + if (strncmp (outstr, "value", len) == 0) + return (HS_VALUE) + if (strncmp (outstr, "comment", len) == 0) + return (HS_COMMENT) + if (strncmp (outstr, "after", len) == 0) + return (HS_AFTER) + if (strncmp (outstr, "before", len) == 0) + return (HS_BEFORE) + if (strncmp (outstr, "add", len) == 0) + return (HS_ADD) + if (strncmp (outstr, "addonly", len) == 0) + return (HS_ADDONLY) + if (strncmp (outstr, "delete", len) == 0) + return (HS_DELETE) + if (strncmp (outstr, "rename", len) == 0) + return (HS_RENAME) + if (strncmp (outstr, "verify", len) == 0) + return (HS_VERIFY) + if (strncmp (outstr, "show", len) == 0) { + return (HS_SHOW) + } + if (strncmp (outstr, "update", len) == 0) + return (HS_UPDATE) + + return (0) # not recognized; probably a value +end + + +# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character +# position in the 'ksection' string. Put the values in the FKS structure. + +procedure he_ks_gvalue (param, cmd, ip, hc) + +int param #I parameter code +char cmd[ARB] #I Ksection +int ip #I Current parsing pointer in ksection +pointer hc #U Update the values in the FKS structure + +pointer sp, ln +int jp, token +int ctotok() +errchk syserr, syserrs + +begin + jp = ip + + call smark (sp) + call salloc (ln, LEN_CARD, TY_CHAR) + + # See if the parameter value is given as par= or '+/-' + if (ctotok (cmd, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { + if (Memc[ln] == '=' ) { + token = ctotok (cmd, jp, Memc[ln], LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && token != TOK_NUMBER) { + call syserr (SYS_FXFKSSYN) + } else { + call he_ks_val (Memc[ln], param, hc) + ip = jp + } + } else if (Memc[ln] == '+' || Memc[ln] == '-') { + call he_ks_pm (Memc[ln], param, hc) + ip = jp + } + } + + call sfree (sp) +end + + +# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. + +procedure he_ks_val (outstr, param, hc) + +char outstr[ARB] #I Input string with value +int param #I Parameter code +pointer hc #U Fits kernel descriptor + +int ival +int strcmp() +errchk syserr, syserrs + +begin + call strlwr (outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (param) { + case HS_FIELD: + call strcpy (outstr, HFIELD(hc), LEN_CARD) + case HS_VALUE: + call strcpy (outstr, HVALUE(hc), LEN_CARD) + case HS_COMMENT: + call strcpy (outstr, HCOMMENT(hc), LEN_CARD) + case HS_BEFORE: + HBAF(hc) = BEFORE + call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) + case HS_AFTER: + HBAF(hc) = AFTER + call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) + case HS_ADD: + HADD(hc) = ival + case HS_ADDONLY: + HADDONLY(hc) = ival + case HS_UPDATE: + HUPDATE(hc) = ival + case HS_VERIFY: + HVERIFY(hc) = ival + case HS_SHOW: + HSHOW(hc) = ival + case HS_DELETE: + HDELETE(hc) = ival + case HS_RENAME: + HRENAME(hc) = ival + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# HE_KS_PM -- Return the character YES or NO based on the value '+' or '-' + +procedure he_ks_pm (pm, param, hc) + +char pm[1] #I contains "+" or "-" +int param #I Parameter code +pointer hc #U Fits kernel descriptor + +int ival +errchk syserr, syserrs + +begin + if (pm[1] == '+') + ival = YES + else + ival = NO + + switch (param) { + case HS_ADD: + HADD(hc) = ival + case HS_ADDONLY: + HADDONLY(hc) = ival + case HS_UPDATE: + HUPDATE(hc) = ival + case HS_VERIFY: + HVERIFY(hc) = ival + case HS_SHOW: + HSHOW(hc) = ival + case HS_DELETE: + HDELETE(hc) = ival + case HS_RENAME: + HRENAME(hc) = ival + default: + call error(13, "ks_pm: invalid value") + } +end + + +# FXF_KSINIT -- Initialize default values for ks parameters. + +procedure he_ksinit (hc) + +pointer hc #I + +begin + HADD(hc) = -1 + HADDONLY(hc) = -1 + HDELETE(hc) = -1 + HRENAME(hc) = -1 + HUPDATE(hc) = -1 + HVERIFY(hc) = -1 + HSHOW(hc) = -1 +end diff --git a/pkg/images/imutil/src/gettok.h b/pkg/images/imutil/src/gettok.h new file mode 100644 index 00000000..d0cfd1ca --- /dev/null +++ b/pkg/images/imutil/src/gettok.h @@ -0,0 +1,22 @@ +# GETTOK.H -- External definitions for gettok.h + +define GT_IDENT (-99) +define GT_NUMBER (-98) +define GT_STRING (-97) +define GT_COMMAND (-96) +define GT_PLUSEQ (-95) +define GT_COLONEQ (-94) +define GT_EXPON (-93) +define GT_CONCAT (-92) +define GT_SE (-91) +define GT_LE (-90) +define GT_GE (-89) +define GT_EQ (-88) +define GT_NE (-87) +define GT_LAND (-86) +define GT_LOR (-85) + +# Optionl flags. +define GT_NOSPECIAL 0003 +define GT_NOFILE 0001 +define GT_NOCOMMAND 0002 diff --git a/pkg/images/imutil/src/gettok.x b/pkg/images/imutil/src/gettok.x new file mode 100644 index 00000000..a0975300 --- /dev/null +++ b/pkg/images/imutil/src/gettok.x @@ -0,0 +1,922 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "gettok.h" + +.help gettok +.nf -------------------------------------------------------------------------- +GETTOK -- Lexical input routines. Used to return tokens from input text, +performing macro expansion and file expansion. The input text may be either +an open file descriptor or a text string. + + nchars = gt_expandtext (text, obuf, len_obuf, gsym, gsym_data) + + gt = gt_open (fd, gsym, gsym_data, pbblen, flags) + gt = gt_opentext (text, gsym, gsym_data, pbblen, flags) + gt_close (gt) + + nchars = gt_expand (gt, obuf, len_obuf) + token = gt_gettok (gt, tokbuf, maxch) + gt_ungettok (gt, tokbuf) + token = gt_rawtok (gt, tokbuf, maxch) + token = gt_nexttok (gt) + +The client get-symbol routine has the following calling sequence, where +"nargs" is an output argument which should be set to the number of macro +arguments, if any. Normally this routine will call SYMTAB to do the +symbol lookup, but this is not required. GSYM may be set to NULL if no +macro replacement is desired. + + textp = gsym (gsym_data, symbol, &nargs) + +PBBLEN is the size of the pushback buffer used for macro expansion, and +determines the size of the largest macro replacement string that can be +pushed back. FLAGS may be used to disable certain types of pushback. +Both PBBLEN and FLAGS may be given as zero if the client is happy with the +builtin defaults. + +Access to the package is gained by opening a text string with GT_OPENTEXT. +This returns a descriptor which is passed to GT_GETTOK to read successive +tokens, which may come from the input text string or from any macros, +include files, etc., referenced in the text or in any substituted text. +GT_UNGETTOK pushes a token back into the GT_GETTOK input stream, to be +returned in the next GT_GETTOK call (following macro expansion). GT_EXPAND +will process the entire input text string, expanding any macro references +therein, returning the fully resolved text in the output buffer. A more +macroscopic version of this is GT_EXPANDTEXT, which does the opentext, +expand, and close operations internally, using the builtin defaults. + +GT_RAWTOK returns the next physical token from an input stream (without +macro expansion), and GT_NEXTTOK returns the type of the next *physical* +token (no macro expansion) without actually fetching it (for look ahead +decision making). + +The tokens that can be returned are as follows: + + GT_IDENT [a-zA-Z][a-zA-Z0-9_]* + GT_NUMBER [0-9][0-9a-zA-Z.]*(e|E)?(+|-)?[0-9]* + GT_STRING if "abc" or 'abc', the abc + 'c' other characters, e.g., =+-*/,;:()[] etc + EOF at end of input + +Macro replacement syntax: + + macro push macro with null arglist + macro(arg,arg,...) push macro with argument substitution + @file push contents of file + @file(arg,arg,...) push file with argument substitution + `cmd` substitute output of CL command "cmd" + +where + macro is an identifier, the name of a global macro + or a datafile local macro (parameter) + +In all cases, occurences of $N in the replacement text are replaced by the +macro arguments if any, and macros are recursively expanded. Whitespace, +including newline, equates to a single space, as does EOF (hence always +delimits tokens). Comments (# to end of line) are ignored. All identifiers +in scanned text are checked to see if they are references to predefined +macros, using the client supplied symbol lookup routine. +.endhelp --------------------------------------------------------------------- + +# General definitions. +define MAX_LEVELS 20 # max include file nesting +define MAX_ARGS 9 # max arguments to a macro +define SZ_CMD 80 # `cmd` +define SZ_IBUF 8192 # buffer for macro replacement +define SZ_OBUF 8192 # buffer for macro replacement +define SZ_ARGBUF 256 # argument list to a macro +define SZ_TOKBUF 1024 # token buffer +define DEF_MAXPUSHBACK 16384 # max pushback, macro replacement +define INC_TOKBUF 4096 # increment if expanded text fills + +# The gettok descriptor. +define LEN_GTDES 50 +define GT_FD Memi[$1] # current input stream +define GT_UFD Memi[$1+1] # user (client) input file +define GT_FLAGS Memi[$1+2] # option flags +define GT_PBBLEN Memi[$1+3] # pushback buffer length +define GT_DEBUG Memi[$1+4] # for debug messages +define GT_GSYM Memi[$1+5] # get symbol routine +define GT_GSYMDATA Memi[$1+6] # client data for above +define GT_NEXTCH Memi[$1+7] # lookahead character +define GT_FTEMP Memi[$1+8] # file on stream is a temp file +define GT_LEVEL Memi[$1+9] # current nesting level +define GT_SVFD Memi[$1+10+$2-1]# stacked file descriptors +define GT_SVFTEMP Memi[$1+30+$2-1]# stacked ftemp flags + +# Set to YES to enable debug messages. +define DEBUG NO + + +# GT_EXPANDTEXT -- Perform macro expansion on a text string returning the +# fully resolved text in the client's output buffer. The number of chars +# in the output string is returned as the function value. + +int procedure gt_expandtext (text, obuf, len_obuf, gsym, gsym_data) + +char text[ARB] #I input text to be expanded +pointer obuf #U output buffer +int len_obuf #U size of output buffer +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above + +pointer gt +int nchars +int gt_expand() +pointer gt_opentext() +errchk gt_opentext + +begin + gt = gt_opentext (text, gsym, gsym_data, 0, 0) + nchars = gt_expand (gt, obuf, len_obuf) + call gt_close (gt) + + return (nchars) +end + + +# GT_EXPAND -- Perform macro expansion on a GT text stream returning the +# fully resolved text in the client's output buffer. The number of chars +# in the output string is returned as the function value. + +int procedure gt_expand (gt, obuf, len_obuf) + +pointer gt #I gettok descriptor +pointer obuf #U output buffer +int len_obuf #U size of output buffer + +int token, nchars +pointer sp, tokbuf, op, otop +int gt_gettok(), strlen(), gstrcpy() +errchk realloc + +begin + call smark (sp) + call salloc (tokbuf, SZ_TOKBUF, TY_CHAR) + + # Open input text for macro expanded token input. + otop = obuf + len_obuf + op = obuf + + # Copy tokens to the output, inserting a space after every token. + repeat { + token = gt_gettok (gt, Memc[tokbuf], SZ_TOKBUF) + if (token != EOF) { + if (op + strlen(Memc[tokbuf]) + 3 > otop) { + nchars = op - obuf + len_obuf = len_obuf + INC_TOKBUF + call realloc (obuf, len_obuf, TY_CHAR) + otop = obuf + len_obuf + op = obuf + nchars + } + + if (token == GT_STRING) { + Memc[op] = '"' + op = op + 1 + } + op = op + gstrcpy (Memc[tokbuf], Memc[op], otop-op) + if (token == GT_STRING) { + Memc[op] = '"' + op = op + 1 + } + Memc[op] = ' ' + op = op + 1 + } + } until (token == EOF) + + # Cancel the trailing blank and add the EOS. + if (op > 1 && op < otop) + op = op - 1 + Memc[op] = EOS + + call sfree (sp) + return (op - 1) +end + + +# GT_OPEN -- Open the GETTOK descriptor on a file descriptor. + +pointer procedure gt_open (fd, gsym, gsym_data, pbblen, flags) + +int fd #I input file +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above +int pbblen #I pushback buffer length +int flags #I option flags + +pointer gt +int sz_pbbuf +errchk calloc + +begin + call calloc (gt, LEN_GTDES, TY_STRUCT) + + GT_GSYM(gt) = gsym + GT_GSYMDATA(gt) = gsym_data + GT_FLAGS(gt) = flags + GT_DEBUG(gt) = DEBUG + + GT_FD(gt) = fd + GT_UFD(gt) = fd + + if (pbblen <= 0) + sz_pbbuf = DEF_MAXPUSHBACK + else + sz_pbbuf = pbblen + call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf) + GT_PBBLEN(gt) = sz_pbbuf + + return (gt) +end + + +# GT_OPENTEXT -- Open the GT_GETTOK descriptor. The descriptor is initially +# opened on the user supplied string buffer (which is opened as a file and +# which must remain intact while token input is in progress), but include file +# processing etc. may cause arbitrary nesting of file descriptors. + +pointer procedure gt_opentext (text, gsym, gsym_data, pbblen, flags) + +char text[ARB] #I input text to be scanned +int gsym #I epa of client get-symbol routine +int gsym_data #I client data for above +int pbblen #I pushback buffer length +int flags #I option flags + +pointer gt +int sz_pbbuf +int stropen(), strlen() +errchk stropen, calloc + +begin + call calloc (gt, LEN_GTDES, TY_STRUCT) + + GT_GSYM(gt) = gsym + GT_GSYMDATA(gt) = gsym_data + GT_FLAGS(gt) = flags + GT_DEBUG(gt) = DEBUG + + GT_FD(gt) = stropen (text, strlen(text), READ_ONLY) + GT_UFD(gt) = 0 + + if (pbblen <= 0) + sz_pbbuf = DEF_MAXPUSHBACK + else + sz_pbbuf = pbblen + call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf) + GT_PBBLEN(gt) = sz_pbbuf + + return (gt) +end + + +# GT_GETTOK -- Return the next token from the input stream. The token ID +# (a predefined integer code or the character value) is returned as the +# function value. The text of the token is returned as an output argument. +# Any macro references, file includes, etc., are performed in the process +# of scanning the input stream, hence only fully resolved tokens are output. + +int procedure gt_gettok (gt, tokbuf, maxch) + +pointer gt #I gettok descriptor +char tokbuf[maxch] #O receives the text of the token +int maxch #I max chars out + +pointer sp, bp, cmd, ibuf, obuf, argbuf, fname, textp +int fd, token, level, margs, nargs, nchars, i_fd, o_fd, ftemp + +int strmac(), open(), stropen() +int gt_rawtok(), gt_nexttok(), gt_arglist(), zfunc3() +errchk gt_rawtok, close, ungetci, ungetline, gt_arglist, +errchk clcmdw, stropen, syserr, zfunc3 +define pushfile_ 91 + + +begin + call smark (sp) + + # Allocate some buffer space. + nchars = SZ_CMD + SZ_IBUF + SZ_OBUF + SZ_ARGBUF + SZ_FNAME + 5 + call salloc (bp, nchars, TY_CHAR) + + cmd = bp + ibuf = cmd + SZ_CMD + 1 + obuf = ibuf + SZ_IBUF + 1 + argbuf = obuf + SZ_OBUF + 1 + fname = argbuf + SZ_ARGBUF + 1 + + # Read raw tokens and push back macro or include file text until we + # get a fully resolved token. + + repeat { + fd = GT_FD(gt) + + # Get a raw token. + token = gt_rawtok (gt, tokbuf, maxch) + + # Process special tokens. + switch (token) { + case EOF: + # EOF has been reached on the current stream. + level = GT_LEVEL(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + if (level > 0) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else if (level > 0) + call close (fd) + + if (level > 0) { + # Restore previous stream. + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + GT_LEVEL(gt) = level - 1 + GT_NEXTCH(gt) = NULL + } else { + # Return EOF token to caller. + call strcpy ("EOF", tokbuf, maxch) + break + } + + case GT_IDENT: + # Lookup the identifier in the symbol table. + textp = NULL + if (GT_GSYM(gt) != NULL) + textp = zfunc3 (GT_GSYM(gt), GT_GSYMDATA(gt), tokbuf, margs) + + # Process a defined macro. + if (textp != NULL) { + # If macro does not have any arguments, merely push back + # the replacement text. + + if (margs == 0) { + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[textp]) + next + } + + # Extract argument list, if any, perform argument + # substitution on the macro, and push back the edited + # text to be rescanned. + + if (gt_nexttok(gt) == '(') { + nargs = gt_arglist (gt, Memc[argbuf], SZ_ARGBUF) + if (nargs != margs) { + call eprintf ("macro `%s' called with ") + call pargstr (tokbuf) + call eprintf ("wrong number of arguments\n") + } + + # Pushback the text of a macro with arg substitution. + nchars = strmac (Memc[textp], Memc[argbuf], + Memc[obuf], SZ_OBUF) + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + call ungetline (fd, Memc[obuf]) + next + + } else { + call eprintf ("macro `%s' called with no arguments\n") + call pargstr (tokbuf) + } + } + + # Return a regular identifier. + break + + case GT_COMMAND: + # Send a command to the CL and push back the output. + if (and (GT_FLAGS(gt), GT_NOCOMMAND) != 0) + break + + # Execute the command, spooling the output in a temp file. + call mktemp ("tmp$co", Memc[fname], SZ_FNAME) + call sprintf (Memc[cmd], SZ_LINE, "%s > %s") + call pargstr (tokbuf) + call pargstr (Memc[fname]) + call clcmdw (Memc[cmd]) + + # Open the output file as input text. + call strcpy (Memc[fname], tokbuf, maxch) + nargs = 0 + ftemp = YES + goto pushfile_ + + case '@': + # Pushback the contents of a file. + if (and (GT_FLAGS(gt), GT_NOFILE) != 0) + break + + token = gt_rawtok (gt, tokbuf, maxch) + if (token != GT_IDENT && token != GT_STRING) { + call eprintf ("expected a filename after the `@'\n") + next + } else { + nargs = 0 + if (gt_nexttok(gt) == '(') # ) + nargs = gt_arglist (gt, Memc[argbuf], SZ_ARGBUF) + ftemp = NO + } +pushfile_ + # Attempt to open the file. + iferr (i_fd = open (tokbuf, READ_ONLY, TEXT_FILE)) { + call eprintf ("cannot open `%s'\n") + call pargstr (tokbuf) + next + } + + call fseti (i_fd, F_PBBSIZE, GT_PBBLEN(gt)) + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # If the macro was called with a nonnull argument list, + # attempt to perform argument substitution on the file + # contents. Otherwise merely push the fd. + + if (nargs > 0) { + # Pushback file contents with argument substitution. + o_fd = stropen (Memc[ibuf], SZ_IBUF, NEW_FILE) + + call fcopyo (i_fd, o_fd) + nchars = strmac (Memc[ibuf],Memc[argbuf],Memc[obuf],SZ_OBUF) + call ungetline (fd, Memc[obuf]) + + call close (o_fd) + call close (i_fd) + + } else { + # Push a new input stream. + level = GT_LEVEL(gt) + 1 + if (level > MAX_LEVELS) + call syserr (SYS_FPBOVFL) + + GT_SVFD(gt,level) = GT_FD(gt) + GT_SVFTEMP(gt,level) = GT_FTEMP(gt) + GT_LEVEL(gt) = level + + fd = i_fd + GT_FD(gt) = fd + GT_FTEMP(gt) = ftemp + } + + default: + break + } + } + + if (GT_DEBUG(gt) > 0) { + call eprintf ("token=%d(%o), `%s'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(tokbuf[1])) + call pargstr (tokbuf) + else + call pargstr ("") + } + + call sfree (sp) + return (token) +end + + +# GT_UNGETTOK -- Push a token back into the GT_GETTOK input stream, to be +# returned as the next token by GT_GETTOK. + +procedure gt_ungettok (gt, tokbuf) + +pointer gt #I gettok descriptor +char tokbuf[ARB] #I text of token + +int fd +errchk ungetci + +begin + fd = GT_FD(gt) + + if (GT_DEBUG(gt) > 0) { + call eprintf ("unget token `%s'\n") + call pargstr (tokbuf) + } + + # Cancel lookahead. + if (GT_NEXTCH(gt) > 0) { + call ungetci (fd, GT_NEXTCH(gt)) + GT_NEXTCH(gt) = 0 + } + + # First push back a space to ensure that the token is recognized + # when the input is rescanned. + + call ungetci (fd, ' ') + + # Now push the token text. + call ungetline (fd, tokbuf) +end + + +# GT_RAWTOK -- Get a raw token from the input stream, without performing any +# macro expansion or file inclusion. The text of the token in returned in +# tokbuf, and the token type is returened as the function value. + +int procedure gt_rawtok (gt, outstr, maxch) + +pointer gt #I gettok descriptor +char outstr[maxch] #O receives text of token. +int maxch #I max chars out + +int token, delim, fd, ch, last_ch, op +define again_ 91 +int getci() + +begin + fd = GT_FD(gt) +again_ + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + GT_NEXTCH(gt) = NULL + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') { + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + } + + # Output the first character. + op = 1 + if (ch != EOF && ch != '"' && ch != '\'' && ch != '`') { + outstr[op] = ch + op = op + 1 + } + + # Accumulate token. Some of the token recognition logic used here + # (especially for numbers) is crude, but it is not clear that rigour + # is justified for this application. + + if (ch == EOF) { + call strcpy ("EOF", outstr, maxch) + token = EOF + + } else if (ch == '#') { + # Ignore a comment. + while (getci (fd, ch) != '\n') + if (ch == EOF) + break + goto again_ + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') { + # Identifier. + token = GT_IDENT + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '_' || ch == '$' || ch == '.') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + + } else if (IS_DIGIT(ch)) { + # Number. + token = GT_NUMBER + + # Get number. + while (getci (fd, ch) != EOF) + if (IS_ALNUM(ch) || ch == '.') { + outstr[op] = ch + last_ch = ch + op = min (maxch, op+1) + } else + break + + # Get exponent if any. + if (last_ch == 'E' || last_ch == 'e') { + outstr[op] = ch + op = min (maxch, op+1) + while (getci (fd, ch) != EOF) + if (IS_DIGIT(ch) || ch == '+' || ch == '-') { + outstr[op] = ch + op = min (maxch, op+1) + } else + break + } + + } else if (ch == '"' || ch == '\'' || ch == '`') { + # Quoted string or command. + + if (ch == '`') + token = GT_COMMAND + else + token = GT_STRING + + delim = ch + while (getci (fd, ch) != EOF) + if (ch==delim && (op>1 && outstr[op-1] != '\\') || ch == '\n') + break + else { + outstr[op] = ch + op = min (maxch, op+1) + } + ch = getci (fd, ch) + + } else if (ch == '+') { + # May be the += operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_PLUSEQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '+' + + } else if (ch == ':') { + # May be the := operator. + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_COLONEQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = ':' + + } else if (ch == '*') { + if (getci (fd, ch) != EOF) + if (ch == '*') { + token = GT_EXPON + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '*' + + } else if (ch == '/') { + if (getci (fd, ch) != EOF) + if (ch == '/') { + token = GT_CONCAT + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '/' + + } else if (ch == '?') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_SE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '?' + + } else if (ch == '<') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_LE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '<' + + } else if (ch == '>') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_GE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '>' + + } else if (ch == '=') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_EQ + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '=' + + } else if (ch == '!') { + if (getci (fd, ch) != EOF) + if (ch == '=') { + token = GT_NE + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '!' + + } else if (ch == '&') { + if (getci (fd, ch) != EOF) + if (ch == '&') { + token = GT_LAND + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '&' + + } else if (ch == '|') { + if (getci (fd, ch) != EOF) + if (ch == '|') { + token = GT_LOR + outstr[op] = ch + op = op + 1 + ch = getci (fd, ch) + } else + token = '|' + + } else { + # Other characters. + token = ch + ch = getci (fd, ch) + } + + # Process the lookahead character. + if (IS_WHITE(ch) || ch == '\n') { + repeat { + ch = getci (fd, ch) + } until (!(IS_WHITE(ch) || ch == '\n')) + } + + if (ch != EOF) + GT_NEXTCH(gt) = ch + + outstr[op] = EOS + return (token) +end + + +# GT_NEXTTOK -- Determine the type of the next raw token in the input stream, +# without actually fetching the token. Operators such as GT_EQ etc. are not +# recognized at this level. Note that this is at the same level as +# GT_RAWTOK, i.e., no macro expansion is performed, and the lookahead token +# is that which would be returned by the next gt_rawtok, which is not +# necessarily what gt_gettok would return after macro replacement. + +int procedure gt_nexttok (gt) + +pointer gt #I gettok descriptor + +int token, fd, ch +int getci() + +begin + fd = GT_FD(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + if (ch == EOF) + token = EOF + else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') + token = GT_IDENT + else if (IS_DIGIT(ch)) + token = GT_NUMBER + else if (ch == '"' || ch == '\'') + token = GT_STRING + else if (ch == '`') + token = GT_COMMAND + else + token = ch + + if (GT_DEBUG(gt) > 0) { + call eprintf ("nexttok=%d(%o) `%c'\n") + call pargi (token) + call pargi (max(0,token)) + if (IS_PRINT(ch)) + call pargi (ch) + else + call pargi (0) + } + + return (token) +end + + +# GT_CLOSE -- Close the gettok descriptor and any files opened thereon. + +procedure gt_close (gt) + +pointer gt #I gettok descriptor + +int level, fd +pointer sp, fname + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + for (level=GT_LEVEL(gt); level >= 0; level=level-1) { + fd = GT_FD(gt) + if (GT_FTEMP(gt) == YES) { + call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME) + call close (fd) + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else if (fd != GT_UFD(gt)) + call close (fd) + + if (level > 0) { + GT_FD(gt) = GT_SVFD(gt,level) + GT_FTEMP(gt) = GT_SVFTEMP(gt,level) + } + } + + call mfree (gt, TY_STRUCT) + call sfree (sp) +end + + +# GT_ARGLIST -- Extract a paren and comma delimited argument list to be used +# for substitution into a macro replacement string. Since the result will be +# pushed back and rescanned, we do not have to perform macro substitution on +# the argument list at this level. + +int procedure gt_arglist (gt, argbuf, maxch) + +pointer gt #I gettok descriptor +char argbuf[maxch] #O receives parsed arguments +int maxch #I max chars out + +int level, quote, nargs, op, ch, fd +int getci() + +begin + fd = GT_FD(gt) + + # Get lookahead char if we don't already have one. + ch = GT_NEXTCH(gt) + if (ch <= 0 || IS_WHITE(ch) || ch == '\n') + while (getci (fd, ch) != EOF) + if (!(IS_WHITE(ch) || ch == '\n')) + break + + quote = 0 + level = 1 + nargs = 0 + op = 1 + + if (ch == '(') { + while (getci (fd, ch) != EOF) { + if (ch == '"' || ch == '\'') { + if (quote == 0) + quote = ch + else if (quote == ch) + quote = 0 + + } else if (ch == '(' && quote == 0) { + level = level + 1 + } else if (ch == ')' && quote == 0) { + level = level - 1 + if (level <= 0) { + if (op > 1 && argbuf[op-1] != EOS) + nargs = nargs + 1 + break + } + + } else if (ch == ',' && level == 1 && quote == 0) { + ch = EOS + nargs = nargs + 1 + } else if (ch == '\n') { + ch = ' ' + } else if (ch == '\\' && quote == 0) { + ch = getci (fd, ch) + next + } else if (ch == '#' && quote == 0) { + while (getci (fd, ch) != EOF) + if (ch == '\n') + break + next + } + + argbuf[op] = ch + op = min (maxch, op + 1) + } + + GT_NEXTCH(gt) = NULL + } + + argbuf[op] = EOS + return (nargs) +end diff --git a/pkg/images/imutil/src/hedit.x b/pkg/images/imutil/src/hedit.x new file mode 100644 index 00000000..4dd553bb --- /dev/null +++ b/pkg/images/imutil/src/hedit.x @@ -0,0 +1,806 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 + + +# HEDIT -- Edit or view selected fields of an image header or headers. This +# editor performs a single edit operation upon a relation, e.g., upon a set +# of fields of a set of images. Templates and expressions may be used to +# automatically select the images and fields to be edited, and to compute +# the new value of each field. + +procedure t_hedit() + +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) + +bool noupdate, quit +int imlist, flist, nfields, up, min_lenuserarea +pointer sp, field, sections, s_fields, s_valexpr, im, ip, image, buf +int operation, verify, show, update + +pointer immap() +bool clgetb(), streq() +int btoi(), imtopenp(), imtgetim(), imofnlu(), imgnfn(), getline() +int envfind(), ctoi() + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (s_fields, SZ_LINE, TY_CHAR) + call salloc (s_valexpr, SZ_LINE, TY_CHAR) + call salloc (sections, SZ_FNAME, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + + # Determine type of operation to be performed. The default operation + # is edit. + + operation = OP_EDIT + if (clgetb ("add")) + operation = OP_ADD + else if (clgetb ("addonly")) + operation = OP_INIT + else if (clgetb ("delete")) + operation = OP_DELETE + + # Get list of fields to be edited, added, or deleted. + call clgstr ("fields", Memc[s_fields], SZ_LINE) + for (ip=s_fields; IS_WHITE (Memc[ip]); ip=ip+1) + ; + fields = ip + + # The value expression parameter is not used for the delete operation. + if (operation != OP_DELETE) { + call clgstr ("value", Memc[s_valexpr], SZ_LINE) + for (ip=s_valexpr; IS_WHITE (Memc[ip]); ip=ip+1) + ; + valexpr = ip + while (Memc[ip] != EOS) + ip = ip + 1 + while (ip > valexpr && IS_WHITE (Memc[ip-1])) + ip = ip - 1 + Memc[ip] = EOS + } else { + Memc[s_valexpr] = EOS + valexpr = s_valexpr + } + + # Get switches. If the expression value is ".", meaning print value + # rather than edit, then we do not use the switches. + + if (operation == OP_EDIT && streq (Memc[valexpr], ".")) { + update = NO + verify = NO + show = NO + } else { + update = btoi (clgetb ("update")) + verify = btoi (clgetb ("verify")) + show = btoi (clgetb ("show")) + } + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # set the length of the user area + if (envfind ("min_lenuserarea", Memc[sections], SZ_FNAME) > 0) { + up = 1 + if (ctoi (Memc[sections], up, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr { + if (update == YES) + im = immap (Memc[image], READ_WRITE, min_lenuserarea) + else + im = immap (Memc[image], READ_ONLY, min_lenuserarea) + } then { + call erract (EA_WARN) + next + } + + if (operation == OP_INIT || operation == OP_ADD) { + # Add a field to the image header. This cannot be done within + # the IMGNFN loop because template expansion on the existing + # fields of the image header would discard the new field name + # since it does not yet exist. + + nfields = 1 + call he_getopsetimage (im, Memc[image], Memc[field]) + switch (operation) { + case OP_INIT: + call he_initfield (im, Memc[image], Memc[fields], + Memc[valexpr], verify, show, update) + case OP_ADD: + call he_addfield (im, Memc[image], Memc[fields], + Memc[valexpr], verify, show, update) + } + + } else { + # Open list of fields to be processed. + flist = imofnlu (im, Memc[fields]) + + nfields = 0 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + call he_getopsetimage (im, Memc[image], Memc[field]) + + switch (operation) { + case OP_EDIT: + call he_editfield (im, Memc[image], Memc[field], + Memc[valexpr], verify, show, update) + case OP_DELETE: + call he_deletefield (im, Memc[image], Memc[field], + Memc[valexpr], verify, show, update) + } + nfields = nfields + 1 + } + + call imcfnl (flist) + } + + # Update the image header and unmap the image. + + noupdate = false + quit = false + + if (update == YES) { + if (nfields == 0) + noupdate = true + else if (verify == YES) { + call eprintf ("update %s ? (yes): ") + call pargstr (Memc[image]) + call flush (STDERR) + + if (getline (STDIN, Memc[buf]) == EOF) + noupdate = true + else { + # Strip leading whitespace and trailing newline. + for (ip=buf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == 'q') { + quit = true + noupdate = true + } else if (! (Memc[ip] == '\n' || Memc[ip] == 'y')) + noupdate = true + } + } + + if (noupdate) { + call imseti (im, IM_WHEADER, NO) + call imunmap (im) + } else { + call imunmap (im) + if (show == YES) { + call printf ("%s updated\n") + call pargstr (Memc[image]) + } + } + } else + call imunmap (im) + + call flush (STDOUT) + if (quit) + break + } + + call imtclose (imlist) + call sfree (sp) +end + + +# HE_EDITFIELD -- Edit the value of the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure he_editfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + + if (streq (Memc[newval], ".")) { + # Merely print the value of the field. + + call printf ("%s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + + } else if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + call he_pargstr (Memc[defval]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES) + call he_updatefield (im, image, field, Memc[oldval], + Memc[newval], show) + + call flush (STDOUT) + } + + } else { + call he_updatefield (im, image, field, Memc[oldval], Memc[newval], + show) + } + + call sfree (sp) +end + + +# HE_INITFIELD -- Add a new field to the indicated image. If the field already +# exists do not set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure he_initfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imaddb, imastr, imaddi, imaddr + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call eprintf ("parameter %s,%s already exists\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + switch (O_TYPE(o)) { + case TY_BOOL: + call imaddb (im, field, O_VALB(o)) + case TY_CHAR: + call imastr (im, field, O_VALC(o)) + case TY_INT: + call imaddi (im, field, O_VALI(o)) + case TY_REAL: + call imaddr (im, field, O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# HE_ADDFIELD -- Add a new field to the indicated image. If the field already +# exists, merely set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure he_addfield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imaddb, imastr, imaddi, imaddr + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call he_editfield (im, image, field, valexpr, verify, show, update) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + switch (O_TYPE(o)) { + case TY_BOOL: + call imaddb (im, field, O_VALB(o)) + case TY_CHAR: + call imastr (im, field, O_VALC(o)) + case TY_INT: + call imaddi (im, field, O_VALI(o)) + case TY_REAL: + call imaddr (im, field, O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# HE_DELETEFIELD -- Delete a field from the indicated image. If the field does +# not exist, print a warning message. + +procedure he_deletefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # not used +int verify # verify deletion interactively +int show # print record of edit +int update # enable updating of the image + +pointer sp, ip, newval +int getline(), imaccf() + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + if (imaccf (im, field) == NO) { + call eprintf ("nonexistent field %s,%s\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + if (verify == YES) { + # Delete pending verification. + + call eprintf ("delete %s,%s ? (yes): ") + call pargstr (image) + call pargstr (field) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Strip leading whitespace and trailing newline. + for (ip=newval; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == 'y') { + call imdelf (im, field) + if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + } + + } else { + # Delete without verification. + + iferr (call imdelf (im, field)) + call erract (EA_WARN) + else if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + + call sfree (sp) +end + + +# HE_UPDATEFIELD -- Update the value of an image header field. + +procedure he_updatefield (im, image, field, oldval, newval, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char oldval[ARB] # old value, encoded as a string +char newval[ARB] # old value, encoded as a string +int show # print record of update + +begin + iferr (call impstr (im, field, newval)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (oldval) + call he_pargstr (newval) + } +end + + +# HE_GVAL -- Get the value of an image header field and return it as a string. +# The ficticious special field "$I" (the image name) is recognized in this +# context in addition to the actual header fields. + +procedure he_gval (im, image, field, strval, maxch) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field whose value is to be returned +char strval[ARB] # string value of field (output) +int maxch # max chars out + +begin + if (field[1] == '$' && field[2] == 'I') + call strcpy (image, strval, maxch) + else if (field[1] == '$') + call imgstr (im, field[2], strval, maxch) + else + call imgstr (im, field, strval, maxch) +end + + +# HE_GETOP -- Satisfy an operand request from EVEXPR. In this context, +# operand names refer to the fields of the image header. The following +# special operand names are recognized: +# +# . a string literal, returned as the string "." +# $ the value of the current field +# $F the name of the current field +# $I the name of the current image +# $T the current time, expressed as an integer +# +# The companion procedure HE_GETOPSETIMAGE is used to pass the image pointer +# and image and field names. + +procedure he_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand (output) + +pointer h_im # getop common +char h_image[SZ_IMAGENAME] +char h_field[SZ_FIELDNAME] +common /hegopm/ h_im, h_image, h_field +bool streq() +long clktime() +errchk he_getfield + +begin + if (streq (operand, ".")) { + call xev_initop (o, 1, TY_CHAR) + call strcpy (".", O_VALC(o), 1) + + } else if (streq (operand, "$")) { + call he_getfield (h_im, h_field, o) + + } else if (streq (operand, "$F")) { + call xev_initop (o, SZ_FIELDNAME, TY_CHAR) + call strcpy (h_field, O_VALC(o), SZ_FIELDNAME) + + } else if (streq (operand, "$I")) { + call xev_initop (o, SZ_IMAGENAME, TY_CHAR) + call strcpy (h_image, O_VALC(o), SZ_IMAGENAME) + + } else if (streq (operand, "$T")) { + # Assignment of long into int may fail on some systems. Maybe + # should use type string and let database convert to long... + + call xev_initop (o, 0, TY_INT) + O_VALI(o) = clktime (long(0)) + + } else + call he_getfield (h_im, operand, o) +end + + +# HE_GETFIELD -- Return the value of the named field of the image header as +# an EVEXPR type operand structure. + +procedure he_getfield (im, field, o) + +pointer im # image descriptor +char field[ARB] # name of field to be returned +pointer o # pointer to output operand + +bool imgetb() +int imgeti(), imgftype() +real imgetr() + +begin + switch (imgftype (im, field)) { + case TY_BOOL: + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = imgetb (im, field) + + case TY_SHORT, TY_INT, TY_LONG: + call xev_initop (o, 0, TY_INT) + O_VALI(o) = imgeti (im, field) + + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + call xev_initop (o, 0, TY_REAL) + O_VALR(o) = imgetr (im, field) + + default: + call xev_initop (o, SZ_LINE, TY_CHAR) + call imgstr (im, field, O_VALC(o), SZ_LINE) + } +end + + +# HE_GETOPSETIMAGE -- Set the image pointer, image name, and field name (context +# of getop) in preparation for a getop call by EVEXPR. + +procedure he_getopsetimage (im, image, field) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited + +pointer h_im # getop common +char h_image[SZ_IMAGENAME] +char h_field[SZ_FIELDNAME] +common /hegopm/ h_im, h_image, h_field + +begin + h_im = im + call strcpy (image, h_image, SZ_IMAGENAME) + call strcpy (field, h_field, SZ_FIELDNAME) +end + + +# HE_ENCODEOP -- Encode an operand as returned by EVEXPR as a string. EVEXPR +# operands are restricted to the datatypes bool, int, real, and string. + +procedure he_encodeop (o, outstr, maxch) + +pointer o # operand to be encoded +char outstr[ARB] # output string +int maxch # max chars in outstr + +begin + switch (O_TYPE(o)) { + case TY_BOOL: + call sprintf (outstr, maxch, "%b") + call pargb (O_VALB(o)) + case TY_CHAR: + call sprintf (outstr, maxch, "%s") + call pargstr (O_VALC(o)) + case TY_INT: + call sprintf (outstr, maxch, "%d") + call pargi (O_VALI(o)) + case TY_REAL: + call sprintf (outstr, maxch, "%g") + call pargr (O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } +end + + +# HE_PARGSTR -- Pass a string to a printf statement, enclosing the string +# in quotes if it contains any whitespace. + +procedure he_pargstr (str) + +char str[ARB] # string to be printed +int ip +bool quoteit +pointer sp, op, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + op = buf + Memc[op] = '"' + op = op + 1 + + # Copy string to scratch buffer, enclosed in quotes. Check for + # embedded whitespace. + + quoteit = false + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_WHITE(str[ip])) { # detect whitespace + quoteit = true + Memc[op] = str[ip] + } else if (str[ip] == '\n') { # prettyprint newlines + Memc[op] = '\\' + op = op + 1 + Memc[op] = 'n' + } else # normal characters + Memc[op] = str[ip] + + if (ip < SZ_LINE) + op = op + 1 + } + + # If whitespace was seen pass the quoted string, otherwise pass the + # original input string. + + if (quoteit) { + Memc[op] = '"' + op = op + 1 + Memc[op] = EOS + call pargstr (Memc[buf]) + } else + call pargstr (str) + + call sfree (sp) +end diff --git a/pkg/images/imutil/src/hselect.x b/pkg/images/imutil/src/hselect.x new file mode 100644 index 00000000..5be85627 --- /dev/null +++ b/pkg/images/imutil/src/hselect.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define LEN_USERAREA 28800 # allow for the largest possible header + + +# HSELECT -- Perform a relational select operation upon a set of images. +# Our function is to select all images from the input set matching some +# criteria, printing the listed fields of each selected image on the standard +# output in list form. +# +# N.B.: this task shares code with the HEDIT task. + +procedure t_hselect() + +pointer sp, im, image, fields, expr, missing, section +int imlist, ip, min_lenuserarea +int imtopenp(), imtgetim(), envfind(), ctoi() +pointer immap() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (fields, SZ_LINE, TY_CHAR) + call salloc (expr, SZ_LINE, TY_CHAR) + call salloc (missing, SZ_LINE, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + call clgstr ("fields", Memc[fields], SZ_LINE) + call clgstr ("expr", Memc[expr], SZ_LINE) + call clgstr ("missing", Memc[missing], SZ_LINE) + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # Check size of user area + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[section], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr (im = immap (Memc[image], READ_ONLY, min_lenuserarea)) { + call erract (EA_WARN) + next + } + + call he_getopsetimage (im, Memc[image], Memc[image]) + call hs_select (im, Memc[image], Memc[fields], Memc[expr], + Memc[missing]) + + call imunmap (im) + call flush (STDOUT) + } + + call imtclose (imlist) + call sfree (sp) +end + + +# HS_SELECT -- Evaluate the user supplied boolean expression using the +# header parameter values for an image, and print the values of the listed +# parameters on the standard output if the expression is true. + +procedure hs_select (im, image, fields, expr, missing) + +pointer im # image descriptor +char image[ARB] # name of image being evaluated +char fields[ARB] # fields to be passed if record is selected +char expr[ARB] # exression to be evaluated +char missing[ARB] # missing output value + +int fieldno +pointer o, sp, field, value, flist +pointer evexpr(), imofnlu() +int locpr(), imgnfn() +extern he_getop() +errchk evexpr, imofnlu, imgnfn + +begin + call smark (sp) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + # Evaluate selection criteria. + o = evexpr (expr, locpr(he_getop), 0) + if (O_TYPE(o) != TY_BOOL) + call error (1, "expression must be boolean") + + # Print the values of the listed fields if the record was selected. + if (O_VALB(o)) { + flist = imofnlu (im, fields) + + fieldno = 1 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + iferr { + call he_gval (im, image, Memc[field], Memc[value], SZ_LINE) + } then { + call printf ("\t%s") + call pargstr (missing) + } else { + if (fieldno == 1) { + call printf ("%s") + call he_pargstr (Memc[value]) + } else { + call printf ("\t%s") + call he_pargstr (Memc[value]) + } + } + fieldno = fieldno + 1 + } + call printf ("\n") + + call imcfnl (flist) + call flush (STDOUT) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/iegsym.x b/pkg/images/imutil/src/iegsym.x new file mode 100644 index 00000000..6b7fbabf --- /dev/null +++ b/pkg/images/imutil/src/iegsym.x @@ -0,0 +1,37 @@ +include +include +include +include +include +include +include +include +include "gettok.h" + + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + + + +# IE_GSYM -- Get symbol routine for the gettok package. + +pointer procedure ie_gsym (st, symname, nargs) + +pointer st #I symbol table +char symname[ARB] #I symbol to be looked up +int nargs #O number of macro arguments + +pointer sym +pointer strefsbuf(), stfind() + +begin + sym = stfind (st, symname) + if (sym == NULL) + return (NULL) + + nargs = SYM_NARGS(sym) + return (strefsbuf (st, SYM_TEXT(sym))) +end diff --git a/pkg/images/imutil/src/imaadd.gx b/pkg/images/imutil/src/imaadd.gx new file mode 100644 index 00000000..a31b47fc --- /dev/null +++ b/pkg/images/imutil/src/imaadd.gx @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +$for (silrd) +# IMA_ADD -- Image arithmetic addition. + +procedure ima_add$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector/scalar + # addition to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call aaddk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # addition to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call aaddk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do a vector addition into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call aadd$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imadiv.gx b/pkg/images/imutil/src/imadiv.gx new file mode 100644 index 00000000..0aaac952 --- /dev/null +++ b/pkg/images/imutil/src/imadiv.gx @@ -0,0 +1,75 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_DIV -- Image arithmetic division. + +$for (silrd) +procedure ima_div$t (im_a, im_b, im_c, a, b, c) + +pointer im_a, im_b, im_c +PIXEL a, b, c + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() +PIXEL ima_efnc$t() +extern ima_efnc$t + +PIXEL divzero +common /imadcom$t/ divzero + +begin + # Loop through all of the image lines. + divzero = c + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do a vector + # reciprical to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call arcz$t (a, Mem$t[buf[2]], Mem$t[buf[1]], len, + ima_efnc$t) + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector/scalar + # divide to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amovk$t (divzero, Mem$t[buf[1]], len) + else if (b == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call adivk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do the vector divide to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call advz$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], + len, ima_efnc$t) + } +end + + +# IMA_EFNC -- Error function for division by zero. + +PIXEL procedure ima_efnc$t (a) + +PIXEL a +PIXEL divzero +common /imadcom$t/ divzero + +begin + return (divzero) +end +$endfor diff --git a/pkg/images/imutil/src/imamax.gx b/pkg/images/imutil/src/imamax.gx new file mode 100644 index 00000000..5804825f --- /dev/null +++ b/pkg/images/imutil/src/imamax.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MAX -- Image arithmetic maximum value. + +$for (silrd) +procedure ima_max$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # maximum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call amaxk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # maximum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) + call amaxk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + + # Read imagea and imageb and do a vector-vector maximum + # operation to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amax$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imamin.gx b/pkg/images/imutil/src/imamin.gx new file mode 100644 index 00000000..b0360510 --- /dev/null +++ b/pkg/images/imutil/src/imamin.gx @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MIN -- Image arithmetic minimum value. + +$for (silrd) +procedure ima_min$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb and do the vector/scalar + # minimum to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) + call amink$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + + # If imageb is constant then read imagea and do the vector/scalar + # minimum to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) + call amink$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + + # Read imagea and imageb and do a vector-vector minimum operation + # to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amin$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imamul.gx b/pkg/images/imutil/src/imamul.gx new file mode 100644 index 00000000..a2c2a4d9 --- /dev/null +++ b/pkg/images/imutil/src/imamul.gx @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_MUL -- Image arithmetic multiplication. + +$for (silrd) +procedure ima_mul$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call amulk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea. If the constant + # is 1 do a vector move to imagec otherwise do a vector + # multiply to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 1$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call amulk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do the vector multiply to imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call amul$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imanl.gx b/pkg/images/imutil/src/imanl.gx new file mode 100644 index 00000000..c91631f7 --- /dev/null +++ b/pkg/images/imutil/src/imanl.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_NL -- For each line in the output image lines from the input images +# are returned. The input images are repeated as necessary. EOF is returned +# when the last line of the output image has been reached. One dimensional +# images are read only once and the data pointers are assumed to be unchanged +# from previous calls. The image line vectors must be initialized externally +# and then left untouched. +# +# This procedure is typically used when operations upon lines or pixels +# make sense in mixed dimensioned images. For example to add a one dimensional +# image to all lines of a higher dimensional image or to subtract a +# two dimensional image from all bands of three dimensional image. +# The lengths of the common dimensions should generally be checked +# for equality with xt_imleneq. + +$for (silrd) +int procedure ima_nl$t (im, data, v, nimages) + +pointer im[nimages] # IMIO pointers; the first one is the output +pointer data[nimages] # Returned data pointers +long v[IM_MAXDIM, nimages] # Line vectors +int nimages # Number of images + +int i + +int impnl$t(), imgnl$t() + +begin + if (impnl$t (im[1], data[1], v[1,1]) == EOF) + return (EOF) + + for (i=2; i <= nimages; i=i+1) { + if (imgnl$t (im[i], data[i], v[1,i]) == EOF) { + if (IM_NDIM(im[i]) > 1) { + call amovkl (long(1), v[1,i], IM_MAXDIM) + if (imgnl$t (im[i], data[i], v[1,i]) == EOF) + call error (0, "Error reading image line") + } + } + } + + return (OK) +end +$endfor diff --git a/pkg/images/imutil/src/imasub.gx b/pkg/images/imutil/src/imasub.gx new file mode 100644 index 00000000..4eb2a2c2 --- /dev/null +++ b/pkg/images/imutil/src/imasub.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMA_SUB -- Image arithmetic subtraction. + +$for (silrd) +procedure ima_sub$t (im_a, im_b, im_c, a, b) + +pointer im_a, im_b, im_c +PIXEL a, b + +int len +pointer im[3], buf[3] +long v[IM_MAXDIM, 3] + +int ima_nl$t() + +begin + # Loop through all of the image lines. + im[1] = im_c + len = IM_LEN (im[1], 1) + call amovkl (long(1), v, 3 * IM_MAXDIM) + + # If imagea is constant then read imageb. Do a vector/scalar + # subtraction and then negate the result. + if (im_a == NULL) { + im[2] = im_b + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (a != 0$f) { + call asubk$t (Mem$t[buf[2]], a, Mem$t[buf[1]], len) + call aneg$t (Mem$t[buf[1]], Mem$t[buf[1]], len) + } else + call aneg$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + } + + # If imageb is constant then read imagea and do a vector/scalar + # subtraction to imagec. + } else if (im_b == NULL) { + im[2] = im_a + while (ima_nl$t (im, buf, v, 2) != EOF) { + if (b == 0$f) + call amov$t (Mem$t[buf[2]], Mem$t[buf[1]], len) + else + call asubk$t (Mem$t[buf[2]], b, Mem$t[buf[1]], len) + } + + # Read imagea and imageb and do a vector subtraction into imagec. + } else { + im[2] = im_a + im[3] = im_b + while (ima_nl$t (im, buf, v, 3) != EOF) + call asub$t (Mem$t[buf[2]], Mem$t[buf[3]], Mem$t[buf[1]], len) + } +end +$endfor diff --git a/pkg/images/imutil/src/imdelete.x b/pkg/images/imutil/src/imdelete.x new file mode 100644 index 00000000..204ff7fa --- /dev/null +++ b/pkg/images/imutil/src/imdelete.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# IMDELETE -- Delete a list of images. If image cannot be deleted, warn but do +# not abort. Verify before deleting each image if user wishes. + +procedure t_imdelete() + +bool verify +int list, nchars +pointer sp, tty, imname, im + +pointer ttyodes(), immap() +int imtopenp(), imtgetim(), imaccess(), strlen(), strncmp() +bool clgetb() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + list = imtopenp ("images") + verify = clgetb ("verify") + if (verify) + tty = ttyodes ("terminal") + + while (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + + if (verify) { + # If image does not exist, warn user (since verify mode is + # in effect). + + if (imaccess (Memc[imname], 0) == NO) { + call eprintf ("Warning: %s `%s'\n") + call pargstr ("Cannot delete nonexistent image") + call pargstr (Memc[imname]) + next + } + + # Set default action of verify prompt (override learning of + # most recent response). + + call clputb ("go_ahead", clgetb ("default_action")) + + # Output prompt, with image name. + call printf ("delete image ") + call ttyso (STDOUT, tty, YES) + call printf ("`%s'") + call pargstr (Memc[imname]) + call ttyso (STDOUT, tty, NO) + + # Include portion of image title in prompt. + ifnoerr (im = immap (Memc[imname], READ_ONLY, 0)) { + nchars = strlen (IM_TITLE(im)) + if (nchars > 0) { + call printf (" - %0.28s") + call pargstr (IM_TITLE(im)) + if (nchars > 28) + call printf ("...") + } + iferr (call imunmap (im)) + ; + } + + # Do the query. + if (! clgetb ("go_ahead")) + next + } + + iferr (call imdelete (Memc[imname])) + call erract (EA_WARN) + } + + # Reset the go_ahead parameter, overiding learn mode, in case delete + # is subsequently called from the background. Close tty descriptor. + + if (verify) { + call clputb ("go_ahead", true) + call ttycdes (tty) + } + + call imtclose (list) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imexpr.gx b/pkg/images/imutil/src/imexpr.gx new file mode 100644 index 00000000..139761fc --- /dev/null +++ b/pkg/images/imutil/src/imexpr.gx @@ -0,0 +1,1183 @@ +include +include +include +include +include +include +include +include +include "gettok.h" + + +# IMEXPR.X -- Image expression evaluator. + +define MAX_OPERANDS 26 +define MAX_ALIASES 10 +define DEF_LENINDEX 97 +define DEF_LENSTAB 1024 +define DEF_LENSBUF 8192 +define DEF_LINELEN 32768 + +# Input image operands. +define LEN_IMOPERAND 18 +define IO_OPNAME Memi[$1] # symbolic operand name +define IO_TYPE Memi[$1+1] # operand type +define IO_IM Memi[$1+2] # image pointer if image +define IO_V Memi[$1+3+($2)-1] # image i/o pointer +define IO_DATA Memi[$1+10] # current image line + # align +define IO_OP ($1+12) # pointer to evvexpr operand + +# Image operand types (IO_TYPE). +define IMAGE 1 # image (vector) operand +define NUMERIC 2 # numeric constant +define PARAMETER 3 # image parameter reference + +# Main imexpr descriptor. +define LEN_IMEXPR (24+LEN_IMOPERAND*MAX_OPERANDS) +define IE_ST Memi[$1] # symbol table +define IE_IM Memi[$1+1] # output image +define IE_NDIM Memi[$1+2] # dimension of output image +define IE_AXLEN Memi[$1+3+($2)-1] # dimensions of output image +define IE_INTYPE Memi[$1+10] # minimum input operand type +define IE_OUTTYPE Memi[$1+11] # datatype of output image +define IE_BWIDTH Memi[$1+12] # npixels boundary extension +define IE_BTYPE Memi[$1+13] # type of boundary extension +define IE_BPIXVAL Memr[P2R($1+14)] # boundary pixel value +define IE_V Memi[$1+15+($2)-1] # position in output image +define IE_NOPERANDS Memi[$1+22] # number of input operands + # align +define IE_IMOP ($1+24+(($2)-1)*LEN_IMOPERAND) # image operand array + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + +# Argument list symbol +define LEN_ARGSYM 1 +define ARGNO Memi[$1] + + +# IMEXPR -- Task procedure for the image expression evaluator. This task +# generates an image by evaluating an arbitrary vector expression, which may +# reference other images as input operands. +# +# The input expression may be any legal EVVEXPR expression. Input operands +# must be specified using the reserved names "a" through "z", hence there are +# a maximum of 26 input operands. An input operand may be an image name or +# image section, an image header parameter, a numeric constant, or the name +# of a builtin keyword. Image header parameters are specified as, e.g., +# "a.naxis1" where the operand "a" must be assigned to an input image. The +# special image name "." refers to the output image generated in the last +# call to imexpr, making it easier to perform a sequence of operations. + +procedure t_imexpr() + +double dval +bool verbose, rangecheck +pointer out, st, sp, ie, dims, intype, outtype, ref_im +pointer outim, fname, expr, xexpr, output, section, data, imname +pointer oplist, opnam, opval, param, io, ip, op, o, im, ia, emsg +int len_exprbuf, fd, nchars, noperands, dtype, status, i, j +int ndim, npix, ch, percent, nlines, totlines, flags, mapflag + +real clgetr() +double imgetd() +int imgftype(), clgwrd(), ctod() +bool clgetb(), imgetb(), streq(), strne() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld() +int impnls(), impnli(), impnll(), impnlr(), impnld() +int open(), getci(), ie_getops(), lexnum(), stridxs() +int imgeti(), ctoi(), btoi(), locpr(), clgeti(), strncmp() +pointer ie_getexprdb(), ie_expandtext(), immap() +extern ie_getop(), ie_fcn() +pointer evvexpr() +long fstatl() + +string s_nodata "bad image: no data" +string s_badtype "unknown image type" +define numeric_ 91 +define image_ 92 + +begin + # call memlog ("--------- START IMEXPR -----------") + + call smark (sp) + call salloc (ie, LEN_IMEXPR, TY_STRUCT) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (output, SZ_PATHNAME, TY_CHAR) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (intype, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_FNAME, TY_CHAR) + call salloc (oplist, SZ_LINE, TY_CHAR) + call salloc (opval, SZ_LINE, TY_CHAR) + call salloc (dims, SZ_LINE, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + + # Initialize the main imexpr descriptor. + call aclri (Memi[ie], LEN_IMEXPR) + + verbose = clgetb ("verbose") + rangecheck = clgetb ("rangecheck") + + # Load the expression database, if any. + st = NULL + call clgstr ("exprdb", Memc[fname], SZ_PATHNAME) + if (strne (Memc[fname], "none")) + st = ie_getexprdb (Memc[fname]) + IE_ST(ie) = st + + # Get the expression to be evaluated and expand any file inclusions + # or macro references. + + len_exprbuf = SZ_COMMAND + call malloc (expr, len_exprbuf, TY_CHAR) + call clgstr ("expr", Memc[expr], len_exprbuf) + + if (Memc[expr] == '@') { + fd = open (Memc[expr+1], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + if (nchars > len_exprbuf) { + len_exprbuf = nchars + call realloc (expr, len_exprbuf, TY_CHAR) + } + for (op=expr; getci(fd,ch) != EOF; op = op + 1) { + if (ch == '\n') + Memc[op] = ' ' + else + Memc[op] = ch + } + Memc[op] = EOS + call close (fd) + } + + if (st != NULL) { + xexpr = ie_expandtext (st, Memc[expr]) + call mfree (expr, TY_CHAR) + expr = xexpr + if (verbose) { + call printf ("%s\n") + call pargstr (Memc[expr]) + call flush (STDOUT) + } + } + + # Get output image name. + call clgstr ("output", Memc[output], SZ_PATHNAME) + call imgimage (Memc[output], Memc[imname], SZ_PATHNAME) + + IE_BWIDTH(ie) = clgeti ("bwidth") + IE_BTYPE(ie) = clgwrd ("btype", Memc[oplist], SZ_LINE, + "|constant|nearest|reflect|wrap|project|") + IE_BPIXVAL(ie) = clgetr ("bpixval") + + # Determine the minimum input operand type. + call clgstr ("intype", Memc[intype], SZ_FNAME) + + if (strncmp (Memc[intype], "auto", 4) == 0) + IE_INTYPE(ie) = 0 + else { + switch (Memc[intype]) { + case 'i', 'l': + IE_INTYPE(ie) = TY_INT + case 'r': + IE_INTYPE(ie) = TY_REAL + case 'd': + IE_INTYPE(ie) = TY_DOUBLE + default: + IE_INTYPE(ie) = 0 + } + } + + # Parse the expression and generate a list of input operands. + noperands = ie_getops (st, Memc[expr], Memc[oplist], SZ_LINE) + IE_NOPERANDS(ie) = noperands + + # Process the list of input operands and initialize each operand. + # This means fetch the value of the operand from the CL, determine + # the operand type, and initialize the image operand descriptor. + # The operand list is returned as a sequence of EOS delimited strings. + + opnam = oplist + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (Memc[opnam] == EOS) + call error (1, "malformed operand list") + + call clgstr (Memc[opnam], Memc[opval], SZ_LINE) + IO_OPNAME(io) = Memc[opnam] + ip = opval + + # Initialize the input operand; these values are overwritten below. + o = IO_OP(io) + call aclri (Memi[o], LEN_OPERAND) + + if (Memc[ip] == '.' && (Memc[ip+1] == EOS || Memc[ip+1] == '[')) { + # A "." is shorthand for the last output image. + call strcpy (Memc[ip+1], Memc[section], SZ_FNAME) + call clgstr ("lastout", Memc[opval], SZ_LINE) + call strcat (Memc[section], Memc[opval], SZ_LINE) + goto image_ + + } else if (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.') { + # "a.foo" refers to parameter foo of image A. Mark this as + # a parameter operand for now, and patch it up later. + + IO_TYPE(io) = PARAMETER + IO_DATA(io) = ip + call salloc (IO_DATA(io), SZ_LINE, TY_CHAR) + call strcpy (Memc[ip], Memc[IO_DATA(io)], SZ_LINE) + + } else if (ctod (Memc, ip, dval) > 0) { + if (Memc[ip] != EOS) + goto image_ + + # A numeric constant. +numeric_ IO_TYPE(io) = NUMERIC + + ip = opval + switch (lexnum (Memc, ip, nchars)) { + case LEX_REAL: + dtype = TY_REAL + if (stridxs("dD",Memc[opval]) > 0 || nchars > NDIGITS_RP+3) + dtype = TY_DOUBLE + O_TYPE(o) = dtype + if (dtype == TY_REAL) + O_VALR(o) = dval + else + O_VALD(o) = dval + default: + O_TYPE(o) = TY_INT + O_LEN(o) = 0 + O_VALI(o) = int(dval) + } + + } else { + # Anything else is assumed to be an image name. +image_ + ip = opval + call imgimage (Memc[ip], Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], Memc[imname])) + call error (2, "input and output images cannot be the same") + + im = immap (Memc[ip], READ_ONLY, 0) + + # Set any image options. + if (IE_BWIDTH(ie) > 0) { + call imseti (im, IM_NBNDRYPIX, IE_BWIDTH(ie)) + call imseti (im, IM_TYBNDRY, IE_BTYPE(ie)) + call imsetr (im, IM_BNDRYPIXVAL, IE_BPIXVAL(ie)) + } + + IO_TYPE(io) = IMAGE + call amovkl (1, IO_V(io,1), IM_MAXDIM) + IO_IM(io) = im + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + O_TYPE(o) = IM_PIXTYPE(im) + case TY_COMPLEX: + O_TYPE(o) = TY_REAL + default: # TY_USHORT + O_TYPE(o) = TY_INT + } + + O_TYPE(o) = max (IE_INTYPE(ie), O_TYPE(o)) + O_LEN(o) = IM_LEN(im,1) + O_FLAGS(o) = 0 + + # If one dimensional image read in data and be done with it. + if (IM_NDIM(im) == 1) { + switch (O_TYPE(o)) { + $for (silrd) + case TY_PIXEL: + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + $endfor + default: + call error (4, s_badtype) + } + } + } + + + # Get next operand name. + while (Memc[opnam] != EOS) + opnam = opnam + 1 + opnam = opnam + 1 + } + + # Go back and patch up any "a.foo" type parameter references. The + # reference input operand (e.g. "a") must be of type IMAGE and must + # point to a valid open image. + + do i = 1, noperands { + mapflag = NO + io = IE_IMOP(ie,i) + ip = IO_DATA(io) + if (IO_TYPE(io) != PARAMETER) + next + + # Locate referenced symbolic image operand (e.g. "a"). + ia = NULL + do j = 1, noperands { + ia = IE_IMOP(ie,j) + if (IO_OPNAME(ia) == Memc[ip] && IO_TYPE(ia) == IMAGE) + break + ia = NULL + } + if (ia == NULL && (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.')) { + # The parameter operand is something like 'a.foo' however + # the image operand 'a' is not in the list derived from the + # expression, perhaps because we just want to use a parameter + # from a reference image and not the image itself. In this + # case map the image so we can get the parameter. + + call strcpy (Memc[ip], Memc[opval], 1) + call clgstr (Memc[opval], Memc[opnam], SZ_LINE) + call imgimage (Memc[opnam], Memc[fname], SZ_PATHNAME) + + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + } else + mapflag = YES + + } else if (ia == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + + } else + im = IO_IM(ia) + + # Get the parameter value and set up operand struct. + param = ip + 2 + IO_TYPE(io) = NUMERIC + o = IO_OP(io) + O_LEN(o) = 0 + + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[ip]) + call error (6, Memc[emsg]) + } + + if (mapflag == YES) + call imunmap (im) + } + + # Determine the reference image from which we will inherit image + # attributes such as the WCS. If the user specifies this we use + # the indicated image, otherwise we use the input image operand with + # the highest dimension. + + call clgstr ("refim", Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], "auto")) { + # Locate best reference image (highest dimension). + ndim = 0 + ref_im = NULL + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + if (IM_NDIM(im) > ndim) { + ref_im = im + ndim = IM_NDIM(im) + } + } + } else { + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == Memc[fname] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad wcsimage reference image %s") + call pargstr (Memc[fname]) + call error (7, Memc[emsg]) + } + ref_im = IO_IM(io) + } + + # Determine the dimension and size of the output image. If the "dims" + # parameter is set this determines the image dimension, otherwise we + # determine the best output image dimension and size from the input + # images. The exception is the line length, which is determined by + # the image line operand returned when the first line of the image + # is evaluated. + + call clgstr ("dims", Memc[dims], SZ_LINE) + if (streq (Memc[dims], "auto")) { + # Determine the output image dimensions from the input images. + call amovki (1, IE_AXLEN(ie,2), IM_MAXDIM-1) + IE_AXLEN(ie,1) = 0 + ndim = 1 + + do i = 1, noperands { + io = IE_IMOP(ie,i) + im = IO_IM(io) + if (IO_TYPE(io) != IMAGE || im == NULL) + next + + ndim = max (ndim, IM_NDIM(im)) + do j = 2, IM_NDIM(im) { + npix = IM_LEN(im,j) + if (npix > 1) { + if (IE_AXLEN(ie,j) <= 1) + IE_AXLEN(ie,j) = npix + else + IE_AXLEN(ie,j) = min (IE_AXLEN(ie,j), npix) + } + } + } + IE_NDIM(ie) = ndim + + } else { + # Use user specified output image dimensions. + ndim = 0 + for (ip=dims; ctoi(Memc,ip,npix) > 0; ) { + ndim = ndim + 1 + IE_AXLEN(ie,ndim) = npix + for (ch=Memc[ip]; IS_WHITE(ch) || ch == ','; ch=Memc[ip]) + ip = ip + 1 + } + IE_NDIM(ie) = ndim + } + + # Determine the pixel type of the output image. + call clgstr ("outtype", Memc[outtype], SZ_FNAME) + + if (strncmp (Memc[outtype], "auto", 4) == 0) { + IE_OUTTYPE(ie) = 0 + } else if (strncmp (Memc[outtype], "ref", 3) == 0) { + if (ref_im != NULL) + IE_OUTTYPE(ie) = IM_PIXTYPE(ref_im) + else + IE_OUTTYPE(ie) = 0 + } else { + switch (Memc[outtype]) { + case 'u': + IE_OUTTYPE(ie) = TY_USHORT + case 's': + IE_OUTTYPE(ie) = TY_SHORT + case 'i': + IE_OUTTYPE(ie) = TY_INT + case 'l': + IE_OUTTYPE(ie) = TY_LONG + case 'r': + IE_OUTTYPE(ie) = TY_REAL + case 'd': + IE_OUTTYPE(ie) = TY_DOUBLE + default: + call error (8, "bad outtype") + } + } + + # Open the output image. If the output image name has a section we + # are writing to a section of an existing image. + + call imgsection (Memc[output], Memc[section], SZ_FNAME) + if (Memc[section] != EOS && Memc[section] != NULL) { + outim = immap (Memc[output], READ_WRITE, 0) + IE_AXLEN(ie,1) = IM_LEN(outim,1) + } else { + if (ref_im != NULL) + outim = immap (Memc[output], NEW_COPY, ref_im) + else + outim = immap (Memc[output], NEW_IMAGE, 0) + IM_LEN(outim,1) = 0 + call amovl (IE_AXLEN(ie,2), IM_LEN(outim,2), IM_MAXDIM-1) + IM_NDIM(outim) = IE_NDIM(ie) + IM_PIXTYPE(outim) = 0 + } + + # Initialize output image line pointer. + call amovkl (1, IE_V(ie,1), IM_MAXDIM) + + percent = 0 + nlines = 0 + totlines = 1 + do i = 2, IM_NDIM(outim) + totlines = totlines * IM_LEN(outim,i) + + # Generate the pixel data for the output image line by line, + # evaluating the user supplied expression to produce each image + # line. Images may be any dimension, datatype, or size. + + # call memlog ("--------- PROCESS IMAGE -----------") + + out = NULL + repeat { + # call memlog1 ("--------- line %d ----------", nlines + 1) + + # Output image line generated by last iteration. + if (out != NULL) { + op = data + if (O_LEN(out) == 0) { + # Output image line is a scalar. + + switch (O_TYPE(out)) { + case TY_BOOL: + Memi[op] = O_VALI(out) + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + $for (silrd) + case TY_PIXEL: + call amovk$t (O_VAL$T(out), Mem$t[op], IM_LEN(outim,1)) + $endfor + } + + } else { + # Output image line is a vector. + + npix = min (O_LEN(out), IM_LEN(outim,1)) + ip = O_VALP(out) + switch (O_TYPE(out)) { + case TY_BOOL: + call amovi (Memi[ip], Memi[op], npix) + $for (silrd) + case TY_PIXEL: + call amov$t (Mem$t[ip], Mem$t[op], npix) + $endfor + } + } + + call evvfree (out) + out = NULL + } + + # Get the next line in all input images. If EOF is seen on the + # image we merely rewind and keep going. This allows a vector, + # plane, etc. to be applied to each line, band, etc. of a higher + # dimensioned image. + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + o = IO_OP(io) + + # Data for a 1D image was read in above. + if (IM_NDIM(im) == 1) + next + + switch (O_TYPE(o)) { + $for (silrd) + case TY_PIXEL: + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnl$t (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + $endfor + default: + call error (10, s_badtype) + } + } + + # call memlog (".......... enter evvexpr ..........") + + # This is it! Evaluate the vector expression. + flags = 0 + if (rangecheck) + flags = or (flags, EV_RNGCHK) + + out = evvexpr (Memc[expr], + locpr(ie_getop), ie, locpr(ie_fcn), ie, flags) + + # call memlog (".......... exit evvexpr ..........") + + # If the pixel type and line length of the output image are + # still undetermined set them to match the output operand. + + if (IM_PIXTYPE(outim) == 0) { + if (IE_OUTTYPE(ie) == 0) { + if (O_TYPE(out) == TY_BOOL) + IE_OUTTYPE(ie) = TY_INT + else + IE_OUTTYPE(ie) = O_TYPE(out) + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } else + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } + if (IM_LEN(outim,1) == 0) { + if (IE_AXLEN(ie,1) == 0) { + if (O_LEN(out) == 0) { + IE_AXLEN(ie,1) = 1 + IM_LEN(outim,1) = 1 + } else { + IE_AXLEN(ie,1) = O_LEN(out) + IM_LEN(outim,1) = O_LEN(out) + } + } else + IM_LEN(outim,1) = IE_AXLEN(ie,1) + } + + # Print percent done. + if (verbose) { + nlines = nlines + 1 + if (nlines * 100 / totlines >= percent + 10) { + percent = percent + 10 + call printf ("%2d%% ") + call pargi (percent) + call flush (STDOUT) + } + } + + switch (O_TYPE(out)) { + case TY_BOOL: + status = impnli (outim, data, IE_V(ie,1)) + $for (silrd) + case TY_PIXEL: + status = impnl$t (outim, data, IE_V(ie,1)) + $endfor + default: + call error (11, "expression type incompatible with image") + } + } until (status == EOF) + + # call memlog ("--------- DONE PROCESSING IMAGE -----------") + + if (verbose) { + call printf ("- done\n") + call flush (STDOUT) + } + + # All done. Unmap images. + call imunmap (outim) + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) == IMAGE && IO_IM(io) != NULL) + call imunmap (IO_IM(io)) + } + + # Clean up. + do i = 1, noperands { + io = IE_IMOP(ie,i) + o = IO_OP(io) + if (O_TYPE(o) == TY_CHAR) + call mfree (O_VALP(o), TY_CHAR) + } + + call evvfree (out) + call mfree (expr, TY_CHAR) + if (st != NULL) + call stclose (st) + + call clpstr ("lastout", Memc[output]) + call sfree (sp) +end + + +# IE_GETOP -- Called by evvexpr to fetch an input image operand. + +procedure ie_getop (ie, opname, o) + +pointer ie #I imexpr descriptor +char opname[ARB] #I operand name +pointer o #I output operand to be filled in + +int axis, i +pointer param, data +pointer sp, im, io, v + +bool imgetb() +int imgeti() +double imgetd() +int imgftype(), btoi() +errchk malloc +define err_ 91 + +begin + call smark (sp) + + if (IS_LOWER(opname[1]) && opname[2] == EOS) { + # Image operand. + + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1]) + break + io = NULL + } + + if (io == NULL) + goto err_ + else + v = IO_OP(io) + + call amovi (Memi[v], Memi[o], LEN_OPERAND) + if (IO_TYPE(io) == IMAGE) { + O_VALP(o) = IO_DATA(io) + O_FLAGS(o) = 0 + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[2] == '.') { + # Image parameter reference, e.g., "a.foo". + call salloc (param, SZ_FNAME, TY_CHAR) + + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) + goto err_ + + # Get the parameter value and set up operand struct. + call strcpy (opname[3], Memc[param], SZ_FNAME) + im = IO_IM(io) + + iferr (O_TYPE(o) = imgftype (im, Memc[param])) + goto err_ + + switch (O_TYPE(o)) { + case TY_BOOL: + iferr (O_VALI(o) = btoi (imgetb (im, Memc[param]))) + goto err_ + + case TY_CHAR: + O_LEN(o) = SZ_LINE + O_FLAGS(o) = O_FREEVAL + iferr { + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + } then + goto err_ + + case TY_INT: + iferr (O_VALI(o) = imgeti (im, Memc[param])) + goto err_ + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + iferr (O_VALD(o) = imgetd (im, Memc[param])) + goto err_ + + default: + goto err_ + } + + call sfree (sp) + return + + } else if (IS_UPPER(opname[1]) && opname[2] == EOS) { + # The current pixel coordinate [I,J,K,...]. The line coordinate + # is a special case since the image is computed a line at a time. + # If "I" is requested return a vector where v[i] = i. For J, K, + # etc. just return the scalar index value. + + axis = opname[1] - 'I' + 1 + if (axis == 1) { + O_TYPE(o) = TY_INT + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else { + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + } + call malloc (data, O_LEN(o), TY_INT) + do i = 1, O_LEN(o) + Memi[data+i-1] = i + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } else { + O_TYPE(o) = TY_INT + #O_LEN(o) = 0 + #if (axis < 1 || axis > IM_MAXDIM) + #O_VALI(o) = 1 + #else + #O_VALI(o) = IE_V(ie,axis) + #O_FLAGS(o) = 0 + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + call malloc (data, O_LEN(o), TY_INT) + if (axis < 1 || axis > IM_MAXDIM) + call amovki (1, Memi[data], O_LEN(o)) + else + call amovki (IE_V(ie,axis), Memi[data], O_LEN(o)) + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } + + call sfree (sp) + return + } + +err_ + O_TYPE(o) = ERR + call sfree (sp) +end + + +# IE_FCN -- Called by evvexpr to execute an imexpr special function. + +procedure ie_fcn (ie, fcn, args, nargs, o) + +pointer ie #I imexpr descriptor +char fcn[ARB] #I function name +pointer args[ARB] #I input arguments +int nargs #I number of input arguments +pointer o #I output operand to be filled in + +begin + # No functions yet. + O_TYPE(o) = ERR +end + + +# IE_GETEXPRDB -- Read the expression database into a symbol table. The +# input file has the following structure: +# +# ['(' arg-list ')'][':'|'='] replacement-text +# +# Symbols must be at the beginning of a line. The expression text is +# terminated by a nonempty, noncomment line with no leading whitespace. + +pointer procedure ie_getexprdb (fname) + +char fname[ARB] #I file to be read + +pointer sym, sp, lbuf, st, a_st, ip, symname, tokbuf, text +int tok, fd, line, nargs, op, token, buflen, offset, stpos, n +errchk open, getlline, stopen, stenter, ie_puttok +int open(), getlline(), ctotok(), stpstr() +pointer stopen(), stenter() +define skip_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + call salloc (text, SZ_COMMAND, TY_CHAR) + call salloc (tokbuf, SZ_COMMAND, TY_CHAR) + call salloc (symname, SZ_FNAME, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + st = stopen ("imexpr", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + a_st = stopen ("args", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + line = 0 + + while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + + # Replace single quotes by double quotes because things + # should behave like the command line but this routine + # uses ctotok which treats single quotes as character + # constants. + + for (ip=lbuf; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '\'') + Memc[ip] = '"' + } + + # Skip comments and blank lines. + ip = lbuf + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == '\n' || Memc[ip] == '#') + next + + # Get symbol name. + if (ctotok (Memc,ip,Memc[symname],SZ_FNAME) != TOK_IDENTIFIER) { + call eprintf ("exprdb: expected identifier at line %d\n") + call pargi (line) +skip_ while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + if (Memc[lbuf] == '\n') + break + } + } + + call stmark (a_st, stpos) + + # Check for the optional argument-symbol list. Allow only a + # single space between the symbol name and its argument list, + # otherwise we can't tell the difference between an argument + # list and the parenthesized expression which follows. + + if (Memc[ip] == ' ') + ip = ip + 1 + + if (Memc[ip] == '(') { + ip = ip + 1 + n = 0 + repeat { + tok = ctotok (Memc, ip, Memc[tokbuf], SZ_FNAME) + if (tok == TOK_IDENTIFIER) { + sym = stenter (a_st, Memc[tokbuf], LEN_ARGSYM) + n = n + 1 + ARGNO(sym) = n + } else if (Memc[tokbuf] == ',') { + ; + } else if (Memc[tokbuf] != ')') { + call eprintf ("exprdb: bad arglist at line %d\n") + call pargi (line) + call stfree (a_st, stpos) + goto skip_ + } + } until (Memc[tokbuf] == ')') + } + + # Check for the optional ":" or "=". + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == ':' || Memc[ip] == '=') + ip = ip + 1 + + # Accumulate the expression text. + buflen = SZ_COMMAND + op = 1 + + repeat { + repeat { + token = ctotok (Memc, ip, Memc[tokbuf+1], SZ_COMMAND) + if (Memc[tokbuf] == '#') + break + else if (token != TOK_EOS && token != TOK_NEWLINE) { + if (token == TOK_STRING) { + Memc[tokbuf] = '"' + call strcat ("""", Memc[tokbuf], SZ_COMMAND) + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf]) + } else + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf+1]) + } + } until (token == TOK_EOS) + + if (getlline (fd, Memc[lbuf], SZ_COMMAND) == EOF) + break + else + line = line + 1 + + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (ip == lbuf) { + call ungetline (fd, Memc[lbuf]) + line = line - 1 + break + } + } + + # Free any argument list symbols. + call stfree (a_st, stpos) + + # Scan the expression text and count the number of $N arguments. + nargs = 0 + for (ip=text; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && IS_DIGIT(Memc[ip+1])) { + nargs = max (nargs, TO_INTEG(Memc[ip+1])) + ip = ip + 1 + } + + # Enter symbol in table. + sym = stenter (st, Memc[symname], LEN_SYM) + offset = stpstr (st, Memc[text], 0) + SYM_TEXT(sym) = offset + SYM_NARGS(sym) = nargs + } + + call stclose (a_st) + call sfree (sp) + + return (st) +end + + +# IE_PUTTOK -- Append a token string to a text buffer. + +procedure ie_puttok (a_st, text, op, buflen, token) + +pointer a_st #I argument-symbol table +pointer text #U text buffer +int op #U output pointer +int buflen #U buffer length, chars +char token[ARB] #I token string + +pointer sym +int ip, ch1, ch2 +pointer stfind() +errchk realloc + +begin + # Replace any symbolic arguments by "$N". + if (a_st != NULL && IS_ALPHA(token[1])) { + sym = stfind (a_st, token) + if (sym != NULL) { + token[1] = '$' + token[2] = TO_DIGIT(ARGNO(sym)) + token[3] = EOS + } + } + + # Append the token string to the text buffer. + for (ip=1; token[ip] != EOS; ip=ip+1) { + if (op + 1 > buflen) { + buflen = buflen + SZ_COMMAND + call realloc (text, buflen, TY_CHAR) + } + + # The following is necessary because ctotok parses tokens such as + # "$N", "==", "!=", etc. as two tokens. We need to rejoin these + # characters to make one token. + + if (op > 1 && token[ip+1] == EOS) { + ch1 = Memc[text+op-3] + ch2 = token[ip] + + if (ch1 == '$' && IS_DIGIT(ch2)) + op = op - 1 + else if (ch1 == '*' && ch2 == '*') + op = op - 1 + else if (ch1 == '/' && ch2 == '/') + op = op - 1 + else if (ch1 == '<' && ch2 == '=') + op = op - 1 + else if (ch1 == '>' && ch2 == '=') + op = op - 1 + else if (ch1 == '=' && ch2 == '=') + op = op - 1 + else if (ch1 == '!' && ch2 == '=') + op = op - 1 + else if (ch1 == '?' && ch2 == '=') + op = op - 1 + else if (ch1 == '&' && ch2 == '&') + op = op - 1 + else if (ch1 == '|' && ch2 == '|') + op = op - 1 + } + + Memc[text+op-1] = token[ip] + op = op + 1 + } + + # Append a space to ensure that tokens are delimited. + Memc[text+op-1] = ' ' + op = op + 1 + + Memc[text+op-1] = EOS +end + + +# IE_EXPANDTEXT -- Scan an expression, performing macro substitution on the +# contents and returning a fully expanded string. + +pointer procedure ie_expandtext (st, expr) + +pointer st #I symbol table (macros) +char expr[ARB] #I input expression + +pointer buf, gt +int buflen, nchars +int locpr(), gt_expand() +pointer gt_opentext() +extern ie_gsym() + +begin + buflen = SZ_COMMAND + call malloc (buf, buflen, TY_CHAR) + + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE) + nchars = gt_expand (gt, buf, buflen) + call gt_close (gt) + + return (buf) +end + + +# IE_GETOPS -- Parse the expression and generate a list of input operands. +# The output operand list is returned as a sequence of EOS delimited strings. + +int procedure ie_getops (st, expr, oplist, maxch) + +pointer st #I symbol table +char expr[ARB] #I input expression +char oplist[ARB] #O operand list +int maxch #I max chars out + +int noperands, ch, i +int ops[MAX_OPERANDS] +pointer gt, sp, tokbuf, op + +extern ie_gsym() +pointer gt_opentext() +int locpr(), gt_rawtok(), gt_nexttok() +errchk gt_opentext, gt_rawtok + +begin + call smark (sp) + call salloc (tokbuf, SZ_LINE, TY_CHAR) + + call aclri (ops, MAX_OPERANDS) + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE+GT_NOCOMMAND) + + # This assumes that operand names are the letters "a" to "z". + while (gt_rawtok (gt, Memc[tokbuf], SZ_LINE) != EOF) { + ch = Memc[tokbuf] + if (IS_LOWER(ch) && Memc[tokbuf+1] == EOS) + if (gt_nexttok (gt) != '(') + ops[ch-'a'+1] = 1 + } + + call gt_close (gt) + + op = 1 + noperands = 0 + do i = 1, MAX_OPERANDS + if (ops[i] != 0 && op < maxch) { + oplist[op] = 'a' + i - 1 + op = op + 1 + oplist[op] = EOS + op = op + 1 + noperands = noperands + 1 + } + + oplist[op] = EOS + op = op + 1 + + call sfree (sp) + return (noperands) +end diff --git a/pkg/images/imutil/src/imexpr.x b/pkg/images/imutil/src/imexpr.x new file mode 100644 index 00000000..f23c04d6 --- /dev/null +++ b/pkg/images/imutil/src/imexpr.x @@ -0,0 +1,1263 @@ +include +include +include +include +include +include +include +include +include "gettok.h" + + +# IMEXPR.X -- Image expression evaluator. + +define MAX_OPERANDS 26 +define MAX_ALIASES 10 +define DEF_LENINDEX 97 +define DEF_LENSTAB 1024 +define DEF_LENSBUF 8192 +define DEF_LINELEN 32768 + +# Input image operands. +define LEN_IMOPERAND 18 +define IO_OPNAME Memi[$1] # symbolic operand name +define IO_TYPE Memi[$1+1] # operand type +define IO_IM Memi[$1+2] # image pointer if image +define IO_V Memi[$1+3+($2)-1] # image i/o pointer +define IO_DATA Memi[$1+10] # current image line + # align +define IO_OP ($1+12) # pointer to evvexpr operand + +# Image operand types (IO_TYPE). +define IMAGE 1 # image (vector) operand +define NUMERIC 2 # numeric constant +define PARAMETER 3 # image parameter reference + +# Main imexpr descriptor. +define LEN_IMEXPR (24+LEN_IMOPERAND*MAX_OPERANDS) +define IE_ST Memi[$1] # symbol table +define IE_IM Memi[$1+1] # output image +define IE_NDIM Memi[$1+2] # dimension of output image +define IE_AXLEN Memi[$1+3+($2)-1] # dimensions of output image +define IE_INTYPE Memi[$1+10] # minimum input operand type +define IE_OUTTYPE Memi[$1+11] # datatype of output image +define IE_BWIDTH Memi[$1+12] # npixels boundary extension +define IE_BTYPE Memi[$1+13] # type of boundary extension +define IE_BPIXVAL Memr[P2R($1+14)] # boundary pixel value +define IE_V Memi[$1+15+($2)-1] # position in output image +define IE_NOPERANDS Memi[$1+22] # number of input operands + # align +define IE_IMOP ($1+24+(($2)-1)*LEN_IMOPERAND) # image operand array + +# Expression database symbol. +define LEN_SYM 2 +define SYM_TEXT Memi[$1] +define SYM_NARGS Memi[$1+1] + +# Argument list symbol +define LEN_ARGSYM 1 +define ARGNO Memi[$1] + + +# IMEXPR -- Task procedure for the image expression evaluator. This task +# generates an image by evaluating an arbitrary vector expression, which may +# reference other images as input operands. +# +# The input expression may be any legal EVVEXPR expression. Input operands +# must be specified using the reserved names "a" through "z", hence there are +# a maximum of 26 input operands. An input operand may be an image name or +# image section, an image header parameter, a numeric constant, or the name +# of a builtin keyword. Image header parameters are specified as, e.g., +# "a.naxis1" where the operand "a" must be assigned to an input image. The +# special image name "." refers to the output image generated in the last +# call to imexpr, making it easier to perform a sequence of operations. + +procedure t_imexpr() + +double dval +bool verbose, rangecheck +pointer out, st, sp, ie, dims, intype, outtype, ref_im +pointer outim, fname, expr, xexpr, output, section, data, imname +pointer oplist, opnam, opval, param, io, ip, op, o, im, ia, emsg +int len_exprbuf, fd, nchars, noperands, dtype, status, i, j +int ndim, npix, ch, percent, nlines, totlines, flags, mapflag + +real clgetr() +double imgetd() +int imgftype(), clgwrd(), ctod() +bool clgetb(), imgetb(), streq(), strne() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld() +int impnls(), impnli(), impnll(), impnlr(), impnld() +int open(), getci(), ie_getops(), lexnum(), stridxs() +int imgeti(), ctoi(), btoi(), locpr(), clgeti(), strncmp() +pointer ie_getexprdb(), ie_expandtext(), immap() +extern ie_getop(), ie_fcn() +pointer evvexpr() +long fstatl() + +string s_nodata "bad image: no data" +string s_badtype "unknown image type" +define numeric_ 91 +define image_ 92 + +begin + # call memlog ("--------- START IMEXPR -----------") + + call smark (sp) + call salloc (ie, LEN_IMEXPR, TY_STRUCT) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (output, SZ_PATHNAME, TY_CHAR) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (intype, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_FNAME, TY_CHAR) + call salloc (oplist, SZ_LINE, TY_CHAR) + call salloc (opval, SZ_LINE, TY_CHAR) + call salloc (dims, SZ_LINE, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + + # Initialize the main imexpr descriptor. + call aclri (Memi[ie], LEN_IMEXPR) + + verbose = clgetb ("verbose") + rangecheck = clgetb ("rangecheck") + + # Load the expression database, if any. + st = NULL + call clgstr ("exprdb", Memc[fname], SZ_PATHNAME) + if (strne (Memc[fname], "none")) + st = ie_getexprdb (Memc[fname]) + IE_ST(ie) = st + + # Get the expression to be evaluated and expand any file inclusions + # or macro references. + + len_exprbuf = SZ_COMMAND + call malloc (expr, len_exprbuf, TY_CHAR) + call clgstr ("expr", Memc[expr], len_exprbuf) + + if (Memc[expr] == '@') { + fd = open (Memc[expr+1], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + if (nchars > len_exprbuf) { + len_exprbuf = nchars + call realloc (expr, len_exprbuf, TY_CHAR) + } + for (op=expr; getci(fd,ch) != EOF; op = op + 1) { + if (ch == '\n') + Memc[op] = ' ' + else + Memc[op] = ch + } + Memc[op] = EOS + call close (fd) + } + + if (st != NULL) { + xexpr = ie_expandtext (st, Memc[expr]) + call mfree (expr, TY_CHAR) + expr = xexpr + if (verbose) { + call printf ("%s\n") + call pargstr (Memc[expr]) + call flush (STDOUT) + } + } + + # Get output image name. + call clgstr ("output", Memc[output], SZ_PATHNAME) + call imgimage (Memc[output], Memc[imname], SZ_PATHNAME) + + IE_BWIDTH(ie) = clgeti ("bwidth") + IE_BTYPE(ie) = clgwrd ("btype", Memc[oplist], SZ_LINE, + "|constant|nearest|reflect|wrap|project|") + IE_BPIXVAL(ie) = clgetr ("bpixval") + + # Determine the minimum input operand type. + call clgstr ("intype", Memc[intype], SZ_FNAME) + + if (strncmp (Memc[intype], "auto", 4) == 0) + IE_INTYPE(ie) = 0 + else { + switch (Memc[intype]) { + case 'i', 'l': + IE_INTYPE(ie) = TY_INT + case 'r': + IE_INTYPE(ie) = TY_REAL + case 'd': + IE_INTYPE(ie) = TY_DOUBLE + default: + IE_INTYPE(ie) = 0 + } + } + + # Parse the expression and generate a list of input operands. + noperands = ie_getops (st, Memc[expr], Memc[oplist], SZ_LINE) + IE_NOPERANDS(ie) = noperands + + # Process the list of input operands and initialize each operand. + # This means fetch the value of the operand from the CL, determine + # the operand type, and initialize the image operand descriptor. + # The operand list is returned as a sequence of EOS delimited strings. + + opnam = oplist + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (Memc[opnam] == EOS) + call error (1, "malformed operand list") + + call clgstr (Memc[opnam], Memc[opval], SZ_LINE) + IO_OPNAME(io) = Memc[opnam] + ip = opval + + # Initialize the input operand; these values are overwritten below. + o = IO_OP(io) + call aclri (Memi[o], LEN_OPERAND) + + if (Memc[ip] == '.' && (Memc[ip+1] == EOS || Memc[ip+1] == '[')) { + # A "." is shorthand for the last output image. + call strcpy (Memc[ip+1], Memc[section], SZ_FNAME) + call clgstr ("lastout", Memc[opval], SZ_LINE) + call strcat (Memc[section], Memc[opval], SZ_LINE) + goto image_ + + } else if (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.') { + # "a.foo" refers to parameter foo of image A. Mark this as + # a parameter operand for now, and patch it up later. + + IO_TYPE(io) = PARAMETER + IO_DATA(io) = ip + call salloc (IO_DATA(io), SZ_LINE, TY_CHAR) + call strcpy (Memc[ip], Memc[IO_DATA(io)], SZ_LINE) + + } else if (ctod (Memc, ip, dval) > 0) { + if (Memc[ip] != EOS) + goto image_ + + # A numeric constant. +numeric_ IO_TYPE(io) = NUMERIC + + ip = opval + switch (lexnum (Memc, ip, nchars)) { + case LEX_REAL: + dtype = TY_REAL + if (stridxs("dD",Memc[opval]) > 0 || nchars > NDIGITS_RP+3) + dtype = TY_DOUBLE + O_TYPE(o) = dtype + if (dtype == TY_REAL) + O_VALR(o) = dval + else + O_VALD(o) = dval + default: + O_TYPE(o) = TY_INT + O_LEN(o) = 0 + O_VALI(o) = int(dval) + } + + } else { + # Anything else is assumed to be an image name. +image_ + ip = opval + call imgimage (Memc[ip], Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], Memc[imname])) + call error (2, "input and output images cannot be the same") + + im = immap (Memc[ip], READ_ONLY, 0) + + # Set any image options. + if (IE_BWIDTH(ie) > 0) { + call imseti (im, IM_NBNDRYPIX, IE_BWIDTH(ie)) + call imseti (im, IM_TYBNDRY, IE_BTYPE(ie)) + call imsetr (im, IM_BNDRYPIXVAL, IE_BPIXVAL(ie)) + } + + IO_TYPE(io) = IMAGE + call amovkl (1, IO_V(io,1), IM_MAXDIM) + IO_IM(io) = im + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: + O_TYPE(o) = IM_PIXTYPE(im) + case TY_COMPLEX: + O_TYPE(o) = TY_REAL + default: # TY_USHORT + O_TYPE(o) = TY_INT + } + + O_TYPE(o) = max (IE_INTYPE(ie), O_TYPE(o)) + O_LEN(o) = IM_LEN(im,1) + O_FLAGS(o) = 0 + + # If one dimensional image read in data and be done with it. + if (IM_NDIM(im) == 1) { + switch (O_TYPE(o)) { + + case TY_SHORT: + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_INT: + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_LONG: + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_REAL: + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + case TY_DOUBLE: + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (3, s_nodata) + + default: + call error (4, s_badtype) + } + } + } + + + # Get next operand name. + while (Memc[opnam] != EOS) + opnam = opnam + 1 + opnam = opnam + 1 + } + + # Go back and patch up any "a.foo" type parameter references. The + # reference input operand (e.g. "a") must be of type IMAGE and must + # point to a valid open image. + + do i = 1, noperands { + mapflag = NO + io = IE_IMOP(ie,i) + ip = IO_DATA(io) + if (IO_TYPE(io) != PARAMETER) + next + + # Locate referenced symbolic image operand (e.g. "a"). + ia = NULL + do j = 1, noperands { + ia = IE_IMOP(ie,j) + if (IO_OPNAME(ia) == Memc[ip] && IO_TYPE(ia) == IMAGE) + break + ia = NULL + } + if (ia == NULL && (IS_LOWER(Memc[ip]) && Memc[ip+1] == '.')) { + # The parameter operand is something like 'a.foo' however + # the image operand 'a' is not in the list derived from the + # expression, perhaps because we just want to use a parameter + # from a reference image and not the image itself. In this + # case map the image so we can get the parameter. + + call strcpy (Memc[ip], Memc[opval], 1) + call clgstr (Memc[opval], Memc[opnam], SZ_LINE) + call imgimage (Memc[opnam], Memc[fname], SZ_PATHNAME) + + iferr (im = immap (Memc[fname], READ_ONLY, 0)) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + } else + mapflag = YES + + } else if (ia == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad image parameter reference %s") + call pargstr (Memc[ip]) + call error (5, Memc[emsg]) + + } else + im = IO_IM(ia) + + # Get the parameter value and set up operand struct. + param = ip + 2 + IO_TYPE(io) = NUMERIC + o = IO_OP(io) + O_LEN(o) = 0 + + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[ip]) + call error (6, Memc[emsg]) + } + + if (mapflag == YES) + call imunmap (im) + } + + # Determine the reference image from which we will inherit image + # attributes such as the WCS. If the user specifies this we use + # the indicated image, otherwise we use the input image operand with + # the highest dimension. + + call clgstr ("refim", Memc[fname], SZ_PATHNAME) + if (streq (Memc[fname], "auto")) { + # Locate best reference image (highest dimension). + ndim = 0 + ref_im = NULL + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + if (IM_NDIM(im) > ndim) { + ref_im = im + ndim = IM_NDIM(im) + } + } + } else { + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == Memc[fname] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) { + call sprintf (Memc[emsg], SZ_LINE, + "bad wcsimage reference image %s") + call pargstr (Memc[fname]) + call error (7, Memc[emsg]) + } + ref_im = IO_IM(io) + } + + # Determine the dimension and size of the output image. If the "dims" + # parameter is set this determines the image dimension, otherwise we + # determine the best output image dimension and size from the input + # images. The exception is the line length, which is determined by + # the image line operand returned when the first line of the image + # is evaluated. + + call clgstr ("dims", Memc[dims], SZ_LINE) + if (streq (Memc[dims], "auto")) { + # Determine the output image dimensions from the input images. + call amovki (1, IE_AXLEN(ie,2), IM_MAXDIM-1) + IE_AXLEN(ie,1) = 0 + ndim = 1 + + do i = 1, noperands { + io = IE_IMOP(ie,i) + im = IO_IM(io) + if (IO_TYPE(io) != IMAGE || im == NULL) + next + + ndim = max (ndim, IM_NDIM(im)) + do j = 2, IM_NDIM(im) { + npix = IM_LEN(im,j) + if (npix > 1) { + if (IE_AXLEN(ie,j) <= 1) + IE_AXLEN(ie,j) = npix + else + IE_AXLEN(ie,j) = min (IE_AXLEN(ie,j), npix) + } + } + } + IE_NDIM(ie) = ndim + + } else { + # Use user specified output image dimensions. + ndim = 0 + for (ip=dims; ctoi(Memc,ip,npix) > 0; ) { + ndim = ndim + 1 + IE_AXLEN(ie,ndim) = npix + for (ch=Memc[ip]; IS_WHITE(ch) || ch == ','; ch=Memc[ip]) + ip = ip + 1 + } + IE_NDIM(ie) = ndim + } + + # Determine the pixel type of the output image. + call clgstr ("outtype", Memc[outtype], SZ_FNAME) + + if (strncmp (Memc[outtype], "auto", 4) == 0) { + IE_OUTTYPE(ie) = 0 + } else if (strncmp (Memc[outtype], "ref", 3) == 0) { + if (ref_im != NULL) + IE_OUTTYPE(ie) = IM_PIXTYPE(ref_im) + else + IE_OUTTYPE(ie) = 0 + } else { + switch (Memc[outtype]) { + case 'u': + IE_OUTTYPE(ie) = TY_USHORT + case 's': + IE_OUTTYPE(ie) = TY_SHORT + case 'i': + IE_OUTTYPE(ie) = TY_INT + case 'l': + IE_OUTTYPE(ie) = TY_LONG + case 'r': + IE_OUTTYPE(ie) = TY_REAL + case 'd': + IE_OUTTYPE(ie) = TY_DOUBLE + default: + call error (8, "bad outtype") + } + } + + # Open the output image. If the output image name has a section we + # are writing to a section of an existing image. + + call imgsection (Memc[output], Memc[section], SZ_FNAME) + if (Memc[section] != EOS && Memc[section] != NULL) { + outim = immap (Memc[output], READ_WRITE, 0) + IE_AXLEN(ie,1) = IM_LEN(outim,1) + } else { + if (ref_im != NULL) + outim = immap (Memc[output], NEW_COPY, ref_im) + else + outim = immap (Memc[output], NEW_IMAGE, 0) + IM_LEN(outim,1) = 0 + call amovl (IE_AXLEN(ie,2), IM_LEN(outim,2), IM_MAXDIM-1) + IM_NDIM(outim) = IE_NDIM(ie) + IM_PIXTYPE(outim) = 0 + } + + # Initialize output image line pointer. + call amovkl (1, IE_V(ie,1), IM_MAXDIM) + + percent = 0 + nlines = 0 + totlines = 1 + do i = 2, IM_NDIM(outim) + totlines = totlines * IM_LEN(outim,i) + + # Generate the pixel data for the output image line by line, + # evaluating the user supplied expression to produce each image + # line. Images may be any dimension, datatype, or size. + + # call memlog ("--------- PROCESS IMAGE -----------") + + out = NULL + repeat { + # call memlog1 ("--------- line %d ----------", nlines + 1) + + # Output image line generated by last iteration. + if (out != NULL) { + op = data + if (O_LEN(out) == 0) { + # Output image line is a scalar. + + switch (O_TYPE(out)) { + case TY_BOOL: + Memi[op] = O_VALI(out) + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + + case TY_SHORT: + call amovks (O_VALS(out), Mems[op], IM_LEN(outim,1)) + + case TY_INT: + call amovki (O_VALI(out), Memi[op], IM_LEN(outim,1)) + + case TY_LONG: + call amovkl (O_VALL(out), Meml[op], IM_LEN(outim,1)) + + case TY_REAL: + call amovkr (O_VALR(out), Memr[op], IM_LEN(outim,1)) + + case TY_DOUBLE: + call amovkd (O_VALD(out), Memd[op], IM_LEN(outim,1)) + + } + + } else { + # Output image line is a vector. + + npix = min (O_LEN(out), IM_LEN(outim,1)) + ip = O_VALP(out) + switch (O_TYPE(out)) { + case TY_BOOL: + call amovi (Memi[ip], Memi[op], npix) + + case TY_SHORT: + call amovs (Mems[ip], Mems[op], npix) + + case TY_INT: + call amovi (Memi[ip], Memi[op], npix) + + case TY_LONG: + call amovl (Meml[ip], Meml[op], npix) + + case TY_REAL: + call amovr (Memr[ip], Memr[op], npix) + + case TY_DOUBLE: + call amovd (Memd[ip], Memd[op], npix) + + } + } + + call evvfree (out) + out = NULL + } + + # Get the next line in all input images. If EOF is seen on the + # image we merely rewind and keep going. This allows a vector, + # plane, etc. to be applied to each line, band, etc. of a higher + # dimensioned image. + + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) != IMAGE || IO_IM(io) == NULL) + next + + im = IO_IM(io) + o = IO_OP(io) + + # Data for a 1D image was read in above. + if (IM_NDIM(im) == 1) + next + + switch (O_TYPE(o)) { + + case TY_SHORT: + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnls (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_INT: + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnli (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_LONG: + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnll (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_REAL: + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnlr (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + case TY_DOUBLE: + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) { + call amovkl (1, IO_V(io,1), IM_MAXDIM) + if (imgnld (im, IO_DATA(io), IO_V(io,1)) == EOF) + call error (9, s_nodata) + } + + default: + call error (10, s_badtype) + } + } + + # call memlog (".......... enter evvexpr ..........") + + # This is it! Evaluate the vector expression. + flags = 0 + if (rangecheck) + flags = or (flags, EV_RNGCHK) + + out = evvexpr (Memc[expr], + locpr(ie_getop), ie, locpr(ie_fcn), ie, flags) + + # call memlog (".......... exit evvexpr ..........") + + # If the pixel type and line length of the output image are + # still undetermined set them to match the output operand. + + if (IM_PIXTYPE(outim) == 0) { + if (IE_OUTTYPE(ie) == 0) { + if (O_TYPE(out) == TY_BOOL) + IE_OUTTYPE(ie) = TY_INT + else + IE_OUTTYPE(ie) = O_TYPE(out) + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } else + IM_PIXTYPE(outim) = IE_OUTTYPE(ie) + } + if (IM_LEN(outim,1) == 0) { + if (IE_AXLEN(ie,1) == 0) { + if (O_LEN(out) == 0) { + IE_AXLEN(ie,1) = 1 + IM_LEN(outim,1) = 1 + } else { + IE_AXLEN(ie,1) = O_LEN(out) + IM_LEN(outim,1) = O_LEN(out) + } + } else + IM_LEN(outim,1) = IE_AXLEN(ie,1) + } + + # Print percent done. + if (verbose) { + nlines = nlines + 1 + if (nlines * 100 / totlines >= percent + 10) { + percent = percent + 10 + call printf ("%2d%% ") + call pargi (percent) + call flush (STDOUT) + } + } + + switch (O_TYPE(out)) { + case TY_BOOL: + status = impnli (outim, data, IE_V(ie,1)) + + case TY_SHORT: + status = impnls (outim, data, IE_V(ie,1)) + + case TY_INT: + status = impnli (outim, data, IE_V(ie,1)) + + case TY_LONG: + status = impnll (outim, data, IE_V(ie,1)) + + case TY_REAL: + status = impnlr (outim, data, IE_V(ie,1)) + + case TY_DOUBLE: + status = impnld (outim, data, IE_V(ie,1)) + + default: + call error (11, "expression type incompatible with image") + } + } until (status == EOF) + + # call memlog ("--------- DONE PROCESSING IMAGE -----------") + + if (verbose) { + call printf ("- done\n") + call flush (STDOUT) + } + + # All done. Unmap images. + call imunmap (outim) + do i = 1, noperands { + io = IE_IMOP(ie,i) + if (IO_TYPE(io) == IMAGE && IO_IM(io) != NULL) + call imunmap (IO_IM(io)) + } + + # Clean up. + do i = 1, noperands { + io = IE_IMOP(ie,i) + o = IO_OP(io) + if (O_TYPE(o) == TY_CHAR) + call mfree (O_VALP(o), TY_CHAR) + } + + call evvfree (out) + call mfree (expr, TY_CHAR) + if (st != NULL) + call stclose (st) + + call clpstr ("lastout", Memc[output]) + call sfree (sp) +end + + +# IE_GETOP -- Called by evvexpr to fetch an input image operand. + +procedure ie_getop (ie, opname, o) + +pointer ie #I imexpr descriptor +char opname[ARB] #I operand name +pointer o #I output operand to be filled in + +int axis, i +pointer param, data +pointer sp, im, io, v + +bool imgetb() +int imgeti() +double imgetd() +int imgftype(), btoi() +errchk malloc +define err_ 91 + +begin + call smark (sp) + + if (IS_LOWER(opname[1]) && opname[2] == EOS) { + # Image operand. + + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1]) + break + io = NULL + } + + if (io == NULL) + goto err_ + else + v = IO_OP(io) + + call amovi (Memi[v], Memi[o], LEN_OPERAND) + if (IO_TYPE(io) == IMAGE) { + O_VALP(o) = IO_DATA(io) + O_FLAGS(o) = 0 + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[2] == '.') { + # Image parameter reference, e.g., "a.foo". + call salloc (param, SZ_FNAME, TY_CHAR) + + # Locate referenced symbolic image operand (e.g. "a"). + io = NULL + do i = 1, IE_NOPERANDS(ie) { + io = IE_IMOP(ie,i) + if (IO_OPNAME(io) == opname[1] && IO_TYPE(io) == IMAGE) + break + io = NULL + } + if (io == NULL) + goto err_ + + # Get the parameter value and set up operand struct. + call strcpy (opname[3], Memc[param], SZ_FNAME) + im = IO_IM(io) + + iferr (O_TYPE(o) = imgftype (im, Memc[param])) + goto err_ + + switch (O_TYPE(o)) { + case TY_BOOL: + iferr (O_VALI(o) = btoi (imgetb (im, Memc[param]))) + goto err_ + + case TY_CHAR: + O_LEN(o) = SZ_LINE + O_FLAGS(o) = O_FREEVAL + iferr { + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + } then + goto err_ + + case TY_INT: + iferr (O_VALI(o) = imgeti (im, Memc[param])) + goto err_ + + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + iferr (O_VALD(o) = imgetd (im, Memc[param])) + goto err_ + + default: + goto err_ + } + + call sfree (sp) + return + + } else if (IS_UPPER(opname[1]) && opname[2] == EOS) { + # The current pixel coordinate [I,J,K,...]. The line coordinate + # is a special case since the image is computed a line at a time. + # If "I" is requested return a vector where v[i] = i. For J, K, + # etc. just return the scalar index value. + + axis = opname[1] - 'I' + 1 + if (axis == 1) { + O_TYPE(o) = TY_INT + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else { + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + } + call malloc (data, O_LEN(o), TY_INT) + do i = 1, O_LEN(o) + Memi[data+i-1] = i + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } else { + O_TYPE(o) = TY_INT + #O_LEN(o) = 0 + #if (axis < 1 || axis > IM_MAXDIM) + #O_VALI(o) = 1 + #else + #O_VALI(o) = IE_V(ie,axis) + #O_FLAGS(o) = 0 + if (IE_AXLEN(ie,1) > 0) + O_LEN(o) = IE_AXLEN(ie,1) + else + # Line length not known yet. + O_LEN(o) = DEF_LINELEN + call malloc (data, O_LEN(o), TY_INT) + if (axis < 1 || axis > IM_MAXDIM) + call amovki (1, Memi[data], O_LEN(o)) + else + call amovki (IE_V(ie,axis), Memi[data], O_LEN(o)) + O_VALP(o) = data + O_FLAGS(o) = O_FREEVAL + } + + call sfree (sp) + return + } + +err_ + O_TYPE(o) = ERR + call sfree (sp) +end + + +# IE_FCN -- Called by evvexpr to execute an imexpr special function. + +procedure ie_fcn (ie, fcn, args, nargs, o) + +pointer ie #I imexpr descriptor +char fcn[ARB] #I function name +pointer args[ARB] #I input arguments +int nargs #I number of input arguments +pointer o #I output operand to be filled in + +begin + # No functions yet. + O_TYPE(o) = ERR +end + + +# IE_GETEXPRDB -- Read the expression database into a symbol table. The +# input file has the following structure: +# +# ['(' arg-list ')'][':'|'='] replacement-text +# +# Symbols must be at the beginning of a line. The expression text is +# terminated by a nonempty, noncomment line with no leading whitespace. + +pointer procedure ie_getexprdb (fname) + +char fname[ARB] #I file to be read + +pointer sym, sp, lbuf, st, a_st, ip, symname, tokbuf, text +int tok, fd, line, nargs, op, token, buflen, offset, stpos, n +errchk open, getlline, stopen, stenter, ie_puttok +int open(), getlline(), ctotok(), stpstr() +pointer stopen(), stenter() +define skip_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_COMMAND, TY_CHAR) + call salloc (text, SZ_COMMAND, TY_CHAR) + call salloc (tokbuf, SZ_COMMAND, TY_CHAR) + call salloc (symname, SZ_FNAME, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + st = stopen ("imexpr", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + a_st = stopen ("args", DEF_LENINDEX, DEF_LENSTAB, DEF_LENSBUF) + line = 0 + + while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + + # Replace single quotes by double quotes because things + # should behave like the command line but this routine + # uses ctotok which treats single quotes as character + # constants. + + for (ip=lbuf; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '\'') + Memc[ip] = '"' + } + + # Skip comments and blank lines. + ip = lbuf + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == '\n' || Memc[ip] == '#') + next + + # Get symbol name. + if (ctotok (Memc,ip,Memc[symname],SZ_FNAME) != TOK_IDENTIFIER) { + call eprintf ("exprdb: expected identifier at line %d\n") + call pargi (line) +skip_ while (getlline (fd, Memc[lbuf], SZ_COMMAND) != EOF) { + line = line + 1 + if (Memc[lbuf] == '\n') + break + } + } + + call stmark (a_st, stpos) + + # Check for the optional argument-symbol list. Allow only a + # single space between the symbol name and its argument list, + # otherwise we can't tell the difference between an argument + # list and the parenthesized expression which follows. + + if (Memc[ip] == ' ') + ip = ip + 1 + + if (Memc[ip] == '(') { + ip = ip + 1 + n = 0 + repeat { + tok = ctotok (Memc, ip, Memc[tokbuf], SZ_FNAME) + if (tok == TOK_IDENTIFIER) { + sym = stenter (a_st, Memc[tokbuf], LEN_ARGSYM) + n = n + 1 + ARGNO(sym) = n + } else if (Memc[tokbuf] == ',') { + ; + } else if (Memc[tokbuf] != ')') { + call eprintf ("exprdb: bad arglist at line %d\n") + call pargi (line) + call stfree (a_st, stpos) + goto skip_ + } + } until (Memc[tokbuf] == ')') + } + + # Check for the optional ":" or "=". + while (IS_WHITE(Memc[ip])) + ip = ip + 1 + if (Memc[ip] == ':' || Memc[ip] == '=') + ip = ip + 1 + + # Accumulate the expression text. + buflen = SZ_COMMAND + op = 1 + + repeat { + repeat { + token = ctotok (Memc, ip, Memc[tokbuf+1], SZ_COMMAND) + if (Memc[tokbuf] == '#') + break + else if (token != TOK_EOS && token != TOK_NEWLINE) { + if (token == TOK_STRING) { + Memc[tokbuf] = '"' + call strcat ("""", Memc[tokbuf], SZ_COMMAND) + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf]) + } else + call ie_puttok (a_st, text, op, buflen, + Memc[tokbuf+1]) + } + } until (token == TOK_EOS) + + if (getlline (fd, Memc[lbuf], SZ_COMMAND) == EOF) + break + else + line = line + 1 + + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (ip == lbuf) { + call ungetline (fd, Memc[lbuf]) + line = line - 1 + break + } + } + + # Free any argument list symbols. + call stfree (a_st, stpos) + + # Scan the expression text and count the number of $N arguments. + nargs = 0 + for (ip=text; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == '$' && IS_DIGIT(Memc[ip+1])) { + nargs = max (nargs, TO_INTEG(Memc[ip+1])) + ip = ip + 1 + } + + # Enter symbol in table. + sym = stenter (st, Memc[symname], LEN_SYM) + offset = stpstr (st, Memc[text], 0) + SYM_TEXT(sym) = offset + SYM_NARGS(sym) = nargs + } + + call stclose (a_st) + call sfree (sp) + + return (st) +end + + +# IE_PUTTOK -- Append a token string to a text buffer. + +procedure ie_puttok (a_st, text, op, buflen, token) + +pointer a_st #I argument-symbol table +pointer text #U text buffer +int op #U output pointer +int buflen #U buffer length, chars +char token[ARB] #I token string + +pointer sym +int ip, ch1, ch2 +pointer stfind() +errchk realloc + +begin + # Replace any symbolic arguments by "$N". + if (a_st != NULL && IS_ALPHA(token[1])) { + sym = stfind (a_st, token) + if (sym != NULL) { + token[1] = '$' + token[2] = TO_DIGIT(ARGNO(sym)) + token[3] = EOS + } + } + + # Append the token string to the text buffer. + for (ip=1; token[ip] != EOS; ip=ip+1) { + if (op + 1 > buflen) { + buflen = buflen + SZ_COMMAND + call realloc (text, buflen, TY_CHAR) + } + + # The following is necessary because ctotok parses tokens such as + # "$N", "==", "!=", etc. as two tokens. We need to rejoin these + # characters to make one token. + + if (op > 1 && token[ip+1] == EOS) { + ch1 = Memc[text+op-3] + ch2 = token[ip] + + if (ch1 == '$' && IS_DIGIT(ch2)) + op = op - 1 + else if (ch1 == '*' && ch2 == '*') + op = op - 1 + else if (ch1 == '/' && ch2 == '/') + op = op - 1 + else if (ch1 == '<' && ch2 == '=') + op = op - 1 + else if (ch1 == '>' && ch2 == '=') + op = op - 1 + else if (ch1 == '=' && ch2 == '=') + op = op - 1 + else if (ch1 == '!' && ch2 == '=') + op = op - 1 + else if (ch1 == '?' && ch2 == '=') + op = op - 1 + else if (ch1 == '&' && ch2 == '&') + op = op - 1 + else if (ch1 == '|' && ch2 == '|') + op = op - 1 + } + + Memc[text+op-1] = token[ip] + op = op + 1 + } + + # Append a space to ensure that tokens are delimited. + Memc[text+op-1] = ' ' + op = op + 1 + + Memc[text+op-1] = EOS +end + + +# IE_EXPANDTEXT -- Scan an expression, performing macro substitution on the +# contents and returning a fully expanded string. + +pointer procedure ie_expandtext (st, expr) + +pointer st #I symbol table (macros) +char expr[ARB] #I input expression + +pointer buf, gt +int buflen, nchars +int locpr(), gt_expand() +pointer gt_opentext() +extern ie_gsym() + +begin + buflen = SZ_COMMAND + call malloc (buf, buflen, TY_CHAR) + + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE) + nchars = gt_expand (gt, buf, buflen) + call gt_close (gt) + + return (buf) +end + + +# IE_GETOPS -- Parse the expression and generate a list of input operands. +# The output operand list is returned as a sequence of EOS delimited strings. + +int procedure ie_getops (st, expr, oplist, maxch) + +pointer st #I symbol table +char expr[ARB] #I input expression +char oplist[ARB] #O operand list +int maxch #I max chars out + +int noperands, ch, i +int ops[MAX_OPERANDS] +pointer gt, sp, tokbuf, op + +extern ie_gsym() +pointer gt_opentext() +int locpr(), gt_rawtok(), gt_nexttok() +errchk gt_opentext, gt_rawtok + +begin + call smark (sp) + call salloc (tokbuf, SZ_LINE, TY_CHAR) + + call aclri (ops, MAX_OPERANDS) + gt = gt_opentext (expr, locpr(ie_gsym), st, 0, GT_NOFILE+GT_NOCOMMAND) + + # This assumes that operand names are the letters "a" to "z". + while (gt_rawtok (gt, Memc[tokbuf], SZ_LINE) != EOF) { + ch = Memc[tokbuf] + if (IS_LOWER(ch) && Memc[tokbuf+1] == EOS) + if (gt_nexttok (gt) != '(') + ops[ch-'a'+1] = 1 + } + + call gt_close (gt) + + op = 1 + noperands = 0 + do i = 1, MAX_OPERANDS + if (ops[i] != 0 && op < maxch) { + oplist[op] = 'a' + i - 1 + op = op + 1 + oplist[op] = EOS + op = op + 1 + noperands = noperands + 1 + } + + oplist[op] = EOS + op = op + 1 + + call sfree (sp) + return (noperands) +end diff --git a/pkg/images/imutil/src/imfuncs.gx b/pkg/images/imutil/src/imfuncs.gx new file mode 100644 index 00000000..b63bea59 --- /dev/null +++ b/pkg/images/imutil/src/imfuncs.gx @@ -0,0 +1,786 @@ +include +include +include + +$for (rd) + +# IF_LOG10 -- Compute the base 10 logarithm of image1 and write the results to +# image2. + +procedure if_log10$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_elog$t() +extern if_elog$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call alog$t (Mem$t[buf1], Mem$t[buf2], npix, if_elog$t) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +PIXEL procedure if_elog$t (x) + +PIXEL x # the input pixel value + +begin + return (PIXEL(-MAX_EXPONENT)) +end + + +# IF_ALOG10 -- Take the power of 10 of image1 and write the results to image2. + +procedure if_alog10$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_va10$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VA10 -- Take the antilog (base 10) of a vector. + +procedure if_va10$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of points + +int i +PIXEL maxexp, maxval + +begin + maxexp = MAX_EXPONENT + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= (-maxexp)) + b[i] = 0$f + else + b[i] = 10$f ** a[i] + } +end + + +# IF_LN -- Take the natural log of the pixels in image1 and write the results +# to image2. + +procedure if_ln$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 + +PIXEL if_eln$t() +extern if_eln$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call alln$t (Mem$t[buf1], Mem$t[buf2], npix, if_eln$t) +end + + +# IF_ELN -- The error function for the natural logarithm. + +PIXEL procedure if_eln$t (x) + +PIXEL x # input value + +begin + return (PIXEL (LN_10) * PIXEL(-MAX_EXPONENT)) +end + + +# IF_ALN -- Take the natural antilog of the pixels in image1 and write the +# results to image2. + +procedure if_aln$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_valn$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VALN -- Take the natural antilog of a vector. + +procedure if_valn$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval, eval + +begin + maxexp = log (10$f ** PIXEL (MAX_EXPONENT)) + maxval = MAX_REAL + eval = PIXEL (BASE_E) + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = 0$f + else + b[i] = eval ** a[i] + } +end + + +# IF_SQR -- Take the square root of pixels in image1 and write the results +# to image2. + +procedure if_sqr$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_esqr$t() +extern if_esqr$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call asqr$t (Mem$t[buf1], Mem$t[buf2], npix, if_esqr$t) +end + + +# IF_ESQR -- Error function for the square root. + +PIXEL procedure if_esqr$t (x) + +PIXEL x # input value + +begin + return (0$f) +end + + +# IF_SQUARE -- Take the square of the pixels in image1 and write to image2. +procedure if_square$t (im1, im2) + +pointer im1 # the input image pointer +pointer im2 # the output image pointer + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call apowk$t (Mem$t[buf1], 2, Mem$t[buf2], npix) +end + + +# IF_CBRT -- Take the cube root of the pixels in image1 and write the results +# to image2. + +procedure if_cbrt$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vcbrt$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VCBRT -- Compute the cube root of a vector. + +procedure if_vcbrt$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL onethird + +begin + onethird = 1$f / 3$f + do i = 1, n { + if (a[i] >= 0$f) { + b[i] = a[i] ** onethird + } else { + b[i] = -a[i] + b[i] = - (b[i] ** onethird) + } + } +end + + +# IF_CUBE -- Take the cube of the pixels in image1 and write the results to +# image2. + +procedure if_cube$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call apowk$t (Mem$t[buf1], 3, Mem$t[buf2], npix) +end + + +# IF_COS -- Take cosine of pixels in image1 and write the results to image2. + +procedure if_cos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vcos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VCOS - Compute the cosine of a vector. + +procedure if_vcos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = cos(a[i]) +end + + +# IF_SIN -- Take sine of the pixels in image1 and write the results to image2. + +procedure if_sin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vsin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VSIN - Take the sine of a vector. + +procedure if_vsin$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = sin(a[i]) +end + + +# IF_TAN -- Take tangent of pixels in image1 and write the results to image2. + +procedure if_tan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vtan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VTAN - Take the tangent of a vector. + +procedure if_vtan$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tan(a[i]) +end + + +# IF_ACOS -- Take arccosine of pixels in image1 and write the results to image2. + +procedure if_acos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vacos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VACOS - Take the arccosine of a vector. + +procedure if_vacos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n { + if (a[i] > 1$f) + b[i] = acos (1$f) + else if (a[i] < -1$f) + b[i] = acos (-1$f) + else + b[i] = acos(a[i]) + } +end + + +# IF_ASIN -- Take arcsine of pixels in image1 and write the results to image2. + +procedure if_asin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vasin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VASIN - Take arcsine of vector + +procedure if_vasin$t (a, b, n) + +PIXEL a[n] +PIXEL b[n] +int n + +int i + +begin + do i = 1, n { + if (a[i] > 1$f) + b[i] = asin (1$f) + else if (a[i] < -1$f) + b[i] = asin (-1$f) + else + b[i] = asin(a[i]) + } +end + + +# IF_ATAN -- Take arctangent of pixels in image1 and write the results to +# image2. + +procedure if_atan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vatan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VATAN - Take the arctangent of a vector. + +procedure if_vatan$t (a, b, n) + +PIXEL a[n] +PIXEL b[n] +int n + +int i + +begin + do i = 1, n + b[i] = atan(a[i]) +end + + +# IF_HCOS -- Take the hyperbolic cosine of pixels in image1 and write the +# results to image2. + +procedure if_hcos$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhcos$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHCOS - Take the hyperbolic cosine of a vector. + +procedure if_vhcos$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval + +begin + maxexp = log (10$f ** PIXEL(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (abs (a[i]) >= maxexp) + b[i] = maxval + else + b[i] = cosh (a[i]) + } +end + + +# IF_HSIN -- Take the hyperbolic sine of pixels in image1 and write the +# results to image2. + +procedure if_hsin$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhsin$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHSIN - Take the hyperbolic sine of a vector. + +procedure if_vhsin$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i +PIXEL maxexp, maxval + +begin + maxexp = log (10$f ** PIXEL(MAX_EXPONENT)) + maxval = MAX_REAL + + do i = 1, n { + if (a[i] >= maxexp) + b[i] = maxval + else if (a[i] <= -maxexp) + b[i] = -maxval + else + b[i] = sinh(a[i]) + } +end + + +# IF_HTAN -- Take the hyperbolic tangent of pixels in image1 and write the +# results to image2. + +procedure if_htan$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +pointer buf1, buf2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call if_vhtan$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_VHTAN - Take the hyperbolic tangent of a vector. + +procedure if_vhtan$t (a, b, n) + +PIXEL a[n] # the input vector +PIXEL b[n] # the output vector +int n # the number of pixels + +int i + +begin + do i = 1, n + b[i] = tanh(a[i]) +end + + +# IF_RECIP -- Take the reciprocal of the pixels in image1 and write the +# results to image2. + +procedure if_recip$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +PIXEL if_erecip$t() +extern if_erecip$t() +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call arcz$t (1.0, Mem$t[buf1], Mem$t[buf2], npix, if_erecip$t) +end + + +# IF_ERECIP -- Error function for the reciprocal computation. + +PIXEL procedure if_erecip$t (x) + +PIXEL x + +begin + return (0$f) +end + +$endfor + +$for (lrd) + +# IF_ABS -- Take the absolute value of pixels in image1 and write the results +# to image2. + +procedure if_abs$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call aabs$t (Mem$t[buf1], Mem$t[buf2], npix) +end + + +# IF_NEG -- Take negative of pixels in image1 and write the results to image2. + +procedure if_neg$t (im1, im2) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnl$t(), impnl$t() + +begin + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im1, 1) + while ((imgnl$t (im1, buf1, v1) != EOF) && + (impnl$t (im2, buf2, v2) != EOF)) + call aneg$t (Mem$t[buf1], Mem$t[buf2], npix) +end + +$endfor diff --git a/pkg/images/imutil/src/imfunction.x b/pkg/images/imutil/src/imfunction.x new file mode 100644 index 00000000..08c4813a --- /dev/null +++ b/pkg/images/imutil/src/imfunction.x @@ -0,0 +1,306 @@ +include + +define IF_LOG10 1 +define IF_ALOG10 2 +define IF_LN 3 +define IF_ALN 4 +define IF_SQRT 5 +define IF_SQUARE 6 +define IF_CBRT 7 +define IF_CUBE 8 +define IF_ABS 9 +define IF_NEG 10 +define IF_COS 11 +define IF_SIN 12 +define IF_TAN 13 +define IF_ACOS 14 +define IF_ASIN 15 +define IF_ATAN 16 +define IF_COSH 17 +define IF_SINH 18 +define IF_TANH 19 +define IF_RECIPROCAL 20 + +define FUNCS "|log10|alog10|ln|aln|sqrt|square|cbrt|cube|abs|neg|\ +cos|sin|tan|acos|asin|atan|hcos|hsin|htan|reciprocal|" + +# T_FUNCTION -- Apply a function to a list of images. + +procedure t_imfunction () + +pointer input # input images +pointer output # output images +int func # function +int verbose # verbose mode + +int list1, list2 +pointer sp, image1, image2, image3, function, im1, im2 +bool clgetb() +int clgwrd(), imtopen(), imtgetim(), imtlen(), btoi() +pointer immap() + +begin + # Allocate working space. + + call smark (sp) + call salloc (input, SZ_LINE, TY_CHAR) + call salloc (output, SZ_LINE, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (image3, SZ_FNAME, TY_CHAR) + call salloc (function, SZ_FNAME, TY_CHAR) + + # Get image template list. + + call clgstr ("input", Memc[input], SZ_LINE) + call clgstr ("output", Memc[output], SZ_LINE) + func = clgwrd ("function", Memc[function], SZ_FNAME, FUNCS) + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[input]) + list2 = imtopen (Memc[output]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Input and output image lists don't match") + } + + # Apply function to each input image. Optimize IMIO. + + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[image3], + SZ_FNAME) + im1 = immap (Memc[image1], READ_ONLY, 0) + if (IM_PIXTYPE(im1) == TY_COMPLEX) { + call printf ("%s is datatype complex: skipping\n") + call imunmap (im1) + next + } + im2 = immap (Memc[image2], NEW_COPY, im1) + + switch (func) { + case IF_LOG10: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_log10d (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_log10r (im1, im2) + } + + case IF_ALOG10: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_alog10d (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_alog10r (im1, im2) + } + + case IF_LN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_lnd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_lnr (im1, im2) + } + + case IF_ALN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_alnd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_alnr (im1, im2) + } + + case IF_SQRT: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_sqrd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_sqrr (im1, im2) + } + + case IF_SQUARE: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_squared (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_squarer (im1, im2) + } + + case IF_CBRT: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cbrtd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cbrtr (im1, im2) + } + + case IF_CUBE: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cubed (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cuber (im1, im2) + } + + case IF_ABS: + switch (IM_PIXTYPE(im1)) { + case TY_SHORT, TY_INT, TY_LONG: + call if_absl (im1, im2) + case TY_DOUBLE: + call if_absd (im1, im2) + default: + call if_absr (im1, im2) + } + + case IF_NEG: + # Preserve the original image type. + switch (IM_PIXTYPE(im1)) { + case TY_SHORT, TY_INT, TY_LONG: + call if_negl (im1, im2) + case TY_DOUBLE: + call if_negd (im1, im2) + default: + call if_negr (im1, im2) + } + + case IF_COS: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_cosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_cosr (im1, im2) + } + + case IF_SIN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_sind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_sinr (im1, im2) + } + + case IF_TAN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_tand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_tanr (im1, im2) + } + + case IF_ACOS: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_acosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_acosr (im1, im2) + } + + case IF_ASIN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_asind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_asinr (im1, im2) + } + + case IF_ATAN: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_atand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_atanr (im1, im2) + } + + case IF_COSH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_hcosd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_hcosr (im1, im2) + } + + case IF_SINH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_hsind (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_hsinr (im1, im2) + } + + case IF_TANH: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_htand (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_htanr (im1, im2) + } + + case IF_RECIPROCAL: + switch (IM_PIXTYPE(im1)) { + case TY_DOUBLE: + IM_PIXTYPE (im2) = TY_DOUBLE + call if_recipd (im1, im2) + default: + IM_PIXTYPE (im2) = TY_REAL + call if_recipr (im1, im2) + } + + default: + call error (0, "Undefined function\n") + + } + + if (verbose == YES) { + call printf ("%s -> %s function: %s\n") + call pargstr (Memc[image1]) + call pargstr (Memc[image3]) + call pargstr (Memc[function]) + } + + call imunmap (im1) + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[image3]) + + } + + call imtclose (list1) + call imtclose (list2) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imgets.x b/pkg/images/imutil/src/imgets.x new file mode 100644 index 00000000..c05c14ca --- /dev/null +++ b/pkg/images/imutil/src/imgets.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# IMGETS -- Get the value of an image header parameter as a character string. +# The value is returned as a CL parameter of type string; the type coercion +# facilities of the CL may be used to convert to a different datatype if +# desired. + +procedure t_imgets() + +pointer sp, im +pointer image, param, value +pointer immap() +int ip, op, stridxs() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (value, SZ_LINE, TY_CHAR) + + call clgstr ("image", Memc[image], SZ_FNAME) + call clgstr ("param", Memc[param], SZ_LINE) + + im = immap (Memc[image], READ_ONLY, 0) + + iferr (call imgstr (im, Memc[param], Memc[value], SZ_LINE)) { + call erract (EA_WARN) + call clpstr ("value", "0") + } else { + # Check for special case of string with double quotes. + if (stridxs ("\"", Memc[value]) != 0) { + op = param + for (ip=value; Memc[ip]!=EOS; ip=ip+1) { + if (Memc[ip] == '"') { + Memc[op] = '\\' + op = op + 1 + } + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call clpstr ("value", Memc[param]) + } else + call clpstr ("value", Memc[value]) + } + + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imheader.x b/pkg/images/imutil/src/imheader.x new file mode 100644 index 00000000..57c496fe --- /dev/null +++ b/pkg/images/imutil/src/imheader.x @@ -0,0 +1,303 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include + +define SZ_DIMSTR (IM_MAXDIM*4) +define SZ_MMSTR 40 +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define LMARGIN 0 + + +# IMHEADER -- Read contents of an image header and print on STDOUT. + +procedure t_imheader() + +int list, nimages, errcode +bool long_format, user_fields +pointer sp, template, image, errmsg +int imtopen(), imtgetim(), imtlen(), clgeti(), errget() +bool clgetb() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call salloc (template, SZ_LINE, TY_CHAR) + + if (clgeti ("$nargs") == 0) + call clgstr ("imlist", Memc[template], SZ_LINE) + else + call clgstr ("images", Memc[template], SZ_LINE) + + list = imtopen (Memc[template]) + long_format = clgetb ("longheader") + user_fields = clgetb ("userfields") + nimages = 0 + + if (imtlen (list) <= 0) + call printf ("no images found\n") + else { + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + nimages = nimages + 1 + if (long_format && nimages > 1) + call putci (STDOUT, '\n') + iferr { + call imphdr (STDOUT,Memc[image],long_format,user_fields) + } then { + errcode = errget (Memc[errmsg], SZ_LINE) + call eprintf ("%s: %s\n") + call pargstr (Memc[image]) + call pargstr (Memc[errmsg]) + } + call flush (STDOUT) + } + } + + call imtclose (list) + call sfree (sp) +end + + +# IMPHDR -- Print the contents of an image header. + +procedure imphdr (fd, image, long_format, user_fields) + +int fd +char image[ARB] +bool long_format +bool user_fields + +int hi, i +bool pixfile_ok +pointer im, sp, ctime, mtime, ldim, pdim, title, lbuf, ip +int gstrcpy(), stropen(), getline(), strlen(), stridxs(), imstati() +errchk im_fmt_dimensions, immap, access, stropen, getline +define done_ 91 +pointer immap() + +begin + # Allocate automatic buffers. + call smark (sp) + call salloc (ctime, SZ_TIME, TY_CHAR) + call salloc (mtime, SZ_TIME, TY_CHAR) + call salloc (ldim, SZ_DIMSTR, TY_CHAR) + call salloc (pdim, SZ_DIMSTR, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + im = immap (image, READ_ONLY, 0) + + # Format subscript strings, date strings, mininum and maximum + # pixel values. + + call im_fmt_dimensions (im, Memc[ldim], SZ_DIMSTR, IM_LEN(im,1)) + call im_fmt_dimensions (im, Memc[pdim], SZ_DIMSTR, IM_PHYSLEN(im,1)) + call cnvtime (IM_CTIME(im), Memc[ctime], SZ_TIME) + call cnvtime (IM_MTIME(im), Memc[mtime], SZ_TIME) + + # Strip any trailing whitespace from the title string. + ip = title + gstrcpy (IM_TITLE(im), Memc[title], SZ_LINE) - 1 + while (ip >= title && IS_WHITE(Memc[ip]) || Memc[ip] == '\n') + ip = ip - 1 + Memc[ip+1] = EOS + + # Begin printing image header. + call fprintf (fd, "%s%s[%s]: %s\n") + call pargstr (IM_NAME(im)) + call pargstr (Memc[ldim]) + call pargtype (IM_PIXTYPE(im)) + call pargstr (Memc[title]) + + # All done if not long format. + if (! long_format) + goto done_ + + call fprintf (fd, "%*w%s bad pixels, min=%s, max=%s%s\n") + call pargi (LMARGIN) + if (IM_NBPIX(im) == 0) # num bad pixels + call pargstr ("No") + else + call pargl (IM_NBPIX(im)) + + if (IM_LIMTIME(im) == 0) { # min,max pixel values + do i = 1, 2 + call pargstr ("unknown") + call pargstr ("") + } else { + call pargr (IM_MIN(im)) + call pargr (IM_MAX(im)) + if (IM_LIMTIME(im) < IM_MTIME(im)) + call pargstr (" (old)") + else + call pargstr ("") + } + + call fprintf (fd, + "%*w%s storage mode, physdim %s, length of user area %d s.u.\n") + call pargi (LMARGIN) + call pargstr ("Line") + call pargstr (Memc[pdim]) + call pargi (IM_HDRLEN(im) - LEN_IMHDR) + + call fprintf (fd, "%*wCreated %s, Last modified %s\n") + call pargi (LMARGIN) + call pargstr (Memc[ctime]) # times + call pargstr (Memc[mtime]) + + pixfile_ok = (imstati (im, IM_PIXFD) > 0) + if (!pixfile_ok) { + ifnoerr (call imopsf (im)) + pixfile_ok = (imstati (im, IM_PIXFD) > 0) + if (pixfile_ok) + call close (imstati (im, IM_PIXFD)) + } + if (pixfile_ok) + call strcpy ("[ok]", Memc[lbuf], SZ_LINE) + else + call strcpy ("[NO PIXEL FILE]", Memc[lbuf], SZ_LINE) + + call fprintf (fd, "%*wPixel file \"%s\" %s\n") + call pargi (LMARGIN) + call pargstr (IM_PIXFILE(im)) + call pargstr (Memc[lbuf]) + + # Print the history records. + if (strlen (IM_HISTORY(im)) > 1) { + hi = stropen (IM_HISTORY(im), ARB, READ_ONLY) + while (getline (hi, Memc[lbuf]) != EOF) { + for (i=1; i <= LMARGIN; i=i+1) + call putci (fd, ' ') + call putline (fd, Memc[lbuf]) + if (stridxs ("\n", Memc[lbuf]) == 0) + call putline (fd, "\n") + } + call close (hi) + } + + if (user_fields) + call imh_print_user_area (fd, im) + +done_ + call imunmap (im) + call sfree (sp) +end + + +# IM_FMT_DIMENSIONS -- Format the image dimensions in the form of a subscript, +# i.e., "[nx,ny,nz,...]". + +procedure im_fmt_dimensions (im, outstr, maxch, len_axes) + +pointer im +char outstr[ARB] +int maxch, i, fd, stropen() +long len_axes[ARB] +errchk stropen, fprintf, pargl + +begin + fd = stropen (outstr, maxch, NEW_FILE) + + if (IM_NDIM(im) == 0) { + call fprintf (fd, "[0") + } else { + call fprintf (fd, "[%d") + call pargl (len_axes[1]) + } + + do i = 2, IM_NDIM(im) { + call fprintf (fd, ",%d") + call pargl (len_axes[i]) + } + + call fprintf (fd, "]") + call close (fd) +end + + +# PARGTYPE -- Convert an integer type code into a string, and output the +# string with PARGSTR to FMTIO. + +procedure pargtype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_UBYTE: + call pargstr ("ubyte") + case TY_BOOL: + call pargstr ("bool") + case TY_CHAR: + call pargstr ("char") + case TY_SHORT: + call pargstr ("short") + case TY_USHORT: + call pargstr ("ushort") + case TY_INT: + call pargstr ("int") + case TY_LONG: + call pargstr ("long") + case TY_REAL: + call pargstr ("real") + case TY_DOUBLE: + call pargstr ("double") + case TY_COMPLEX: + call pargstr ("complex") + case TY_POINTER: + call pargstr ("pointer") + case TY_STRUCT: + call pargstr ("struct") + default: + call pargstr ("unknown datatype") + } +end + + +# IMH_PRINT_USER_AREA -- Print the user area of the image, if nonzero length +# and it contains only ascii values. + +procedure imh_print_user_area (out, im) + +int out # output file +pointer im # image descriptor + +pointer sp, lbuf, ip +int in, ncols, min_lenuserarea, i +int stropen(), getline(), envgeti() +errchk stropen, envgeti, getline, putci, putline + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Open user area in header. + min_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY) + ncols = envgeti ("ttyncols") - LMARGIN + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. + + while (getline (in, Memc[lbuf]) != EOF) { + for (ip=lbuf; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + while (ip > lbuf && Memc[ip-1] == ' ') + ip = ip - 1 + if (ip - lbuf > ncols) + ip = lbuf + ncols + Memc[ip] = '\n' + Memc[ip+1] = EOS + + for (i=1; i <= LMARGIN; i=i+1) + call putci (out, ' ') + call putline (out, Memc[lbuf]) + } + + call close (in) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/imhistogram.x b/pkg/images/imutil/src/imhistogram.x new file mode 100644 index 00000000..b62233b7 --- /dev/null +++ b/pkg/images/imutil/src/imhistogram.x @@ -0,0 +1,332 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define SZ_CHOICE 18 + +define HIST_TYPES "|normal|cumulative|difference|second_difference|" +define NORMAL 1 +define CUMULATIVE 2 +define DIFFERENCE 3 +define SECOND_DIFF 4 + +define PLOT_TYPES "|line|box|" +define LINE 1 +define BOX 2 + +define SZ_TITLE 512 # plot title buffer + +# IMHISTOGRAM -- Compute and plot the histogram of an image. + +procedure t_imhistogram() + +long v[IM_MAXDIM] +real z1, z2, dz, z1temp, z2temp, zstart +int npix, nbins, nbins1, nlevels, nwide, z1i, z2i, i, maxch, histtype +pointer gp, im, sp, hgm, hgmr, buf, image, device, str, title, op + +real clgetr() +pointer immap(), gopen() +int clgeti(), clgwrd() +int imgnlr(), imgnli() +bool clgetb(), fp_equalr() + +begin + call smark (sp) + call salloc (image, SZ_LINE, TY_CHAR) + call salloc (str, SZ_CHOICE, TY_CHAR) + + # Get the image name. + call clgstr ("image", Memc[image], SZ_LINE) + im = immap (Memc[image], READ_ONLY, 0) + npix = IM_LEN(im,1) + + # Get histogram range. + z1 = clgetr ("z1") + z2 = clgetr ("z2") + + if (IS_INDEFR(z1) || IS_INDEFR(z2)) { + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + z1temp = IM_MIN(im) + z2temp = IM_MAX(im) + } else + call im_minmax (im, z1temp, z2temp) + + if (IS_INDEFR(z1)) + z1 = z1temp + + if (IS_INDEFR(z2)) + z2 = z2temp + } + + if (z1 > z2) { + dz = z1; z1 = z2; z2 = dz + } + + # Get default histogram resolution. + dz = clgetr ("binwidth") + if (IS_INDEFR(dz)) + nbins = clgeti ("nbins") + else { + nbins = nint ((z2 - z1) / dz) + z2 = z1 + nbins * dz + } + + # Set the limits for integer images. + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + z1i = nint (z1) + z2i = nint (z2) + z1 = real (z1i) + z2 = real (z2i) + } + + # Adjust the resolution of the histogram and/or the data range + # so that an integral number of data values map into each + # histogram bin (to avoid aliasing effects). + + if (clgetb ("autoscale")) + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + nlevels = z2i - z1i + nwide = max (1, nint (real (nlevels) / real (nbins))) + nbins = max (1, nint (real (nlevels) / real (nwide))) + z2i = z1i + nbins * nwide + z2 = real (z2i) + } + + # The extra bin counts the pixels that equal z2 and shifts the + # remaining bins to evenly cover the interval [z1,z2]. + # 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 salloc (hgm, nbins1, TY_INT) + call aclri (Memi[hgm], nbins1) + call amovkl (long(1), v, IM_MAXDIM) + + # Read successive lines of the image and accumulate the histogram. + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + # Test for constant valued image, which causes zero divide in ahgm. + if (z1i == z2i) { + call eprintf ("Warning: Image `%s' has no data range.\n") + call pargstr (Memc[image]) + call imunmap (im) + call sfree (sp) + return + } + + while (imgnli (im, buf, v) != EOF) + call ahgmi (Memi[buf], npix, Memi[hgm], nbins1, z1i, z2i) + + default: + # Test for constant valued image, which causes zero divide in ahgm. + if (fp_equalr (z1, z2)) { + call eprintf ("Warning: Image `%s' has no data range.\n") + call pargstr (Memc[image]) + call imunmap (im) + call sfree (sp) + return + } + + while (imgnlr (im, buf, v) != EOF) + call ahgmr (Memr[buf], 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 ("top_closed")) + Memi[hgm+nbins-1] = Memi[hgm+nbins-1] + Memi[hgm+nbins1-1] + + dz = (z2 - z1) / real (nbins) + + histtype = clgwrd ("hist_type", Memc[str], SZ_CHOICE, HIST_TYPES) + + switch (histtype) { + case NORMAL: + # do nothing + case CUMULATIVE: + call ih_acumi (Memi[hgm], Memi[hgm], nbins) + case DIFFERENCE: + call ih_amrgi (Memi[hgm], Memi[hgm], nbins) + z1 = z1 + dz / 2. + z2 = z2 - dz / 2. + nbins = nbins - 1 + case SECOND_DIFF: + call ih_amrgi (Memi[hgm], Memi[hgm], nbins) + call ih_amrgi (Memi[hgm], Memi[hgm], nbins-1) + z1 = z1 + dz + z2 = z2 - dz + nbins = nbins - 2 + default: + call error (1, "bad switch 1") + } + + # List or plot the histogram. In list format, the bin value is the + # z value of the left side (start) of the bin. + + if (clgetb ("listout")) { + zstart = z1 + dz / 2.0 + do i = 1, nbins { + call printf ("%g %d\n") + call pargr (zstart) + call pargi (Memi[hgm+i-1]) + zstart = zstart + dz + } + } else { + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_TITLE, TY_CHAR) + call salloc (hgmr, nbins, TY_REAL) + call achtir (Memi[hgm], Memr[hgmr], nbins) + + call clgstr ("device", Memc[device], SZ_FNAME) + gp = gopen (Memc[device], NEW_FILE, STDGRAPH) + if (clgetb ("logy")) + call gseti (gp, G_YTRAN, GW_LOG) + call gswind (gp, z1, z2, INDEF, INDEF) + call gascale (gp, Memr[hgmr], nbins, 2) + + # Format the plot title, starting with the system banner. + call sysid (Memc[title], SZ_TITLE) + for (op=title; Memc[op] != '\n' && Memc[op] != EOS; op=op+1) + ; + Memc[op] = '\n'; op = op + 1 + maxch = SZ_TITLE - (op - title) + + # Format the remainder of the plot title. + call sprintf (Memc[op], maxch, + "%s of %s = %s\nFrom z1=%g to z2=%g, nbins=%d, width=%g") + switch (histtype) { + case NORMAL: + call pargstr ("Histogram") + case CUMULATIVE: + call pargstr ("Cumulative histogram") + case DIFFERENCE: + call pargstr ("Difference histogram") + case SECOND_DIFF: + call pargstr ("Second difference histogram") + default: + call error (1, "bad switch 3") + } + + call pargstr (Memc[image]) + call pargstr (IM_TITLE(im)) + call pargr (z1) + call pargr (z2) + call pargi (nbins) + call pargr (dz) + + # Draw the plot. Center the bins for plot_type=line. + call glabax (gp, Memc[title], "", "") + + switch (clgwrd ("plot_type", Memc[str], SZ_LINE, PLOT_TYPES)) { + case LINE: + call gvline (gp, Memr[hgmr], nbins, z1 + dz/2., z2 - dz/2.) + case BOX: + call hgline (gp, Memr[hgmr], nbins, z1, z2) + default: + call error (1, "bad switch 2") + } + + call gclose (gp) + } + + call imunmap (im) + call sfree (sp) +end + + +# HGLINE -- Draw a stepped curve of the histogram data. + +procedure hgline (gp, ydata, npts, x1, x2) + +pointer gp # Graphics descriptor +real ydata[ARB] # Y coordinates of the line endpoints +int npts # Number of line endpoints +real x1, x2 + +int pixel +real x, y, dx + +begin + dx = (x2 - x1) / npts + + # Do the first horizontal line + x = x1 + y = ydata[1] + call gamove (gp, x, y) + x = x + dx + call gadraw (gp, x, y) + + do pixel = 2, npts { + x = x1 + dx * (pixel - 1) + y = ydata[pixel] + # vertical connection + call gadraw (gp, x, y) + # horizontal line + call gadraw (gp, x + dx, y) + } +end + + +# These two routines are intended to be generic vops routines. Only +# the integer versions are included since that's all that's used here. + +# The operation is carried out in such a way that +# the result is the same whether or not the output vector overlaps +# (partially) the input vector. The routines WILL work in place! + +# ACUM -- Compute a cumulative vector (generic). Should b[1] be zero? + +procedure ih_acumi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +# int npix, i, a_first, b_first + +begin +# call zlocva (a, a_first) +# call zlocva (b, b_first) +# +# if (b_first <= a_first) { + # Shouldn't use output arguments internally, + # but no reason to use this routine unsafely. + b[1] = a[1] + do i = 2, npix + b[i] = b[i-1] + a[i] +# } else { + # overlapping solution not implemented yet! +# } +end + + +# AMRG -- Compute a marginal (forward difference) vector (generic). + +procedure ih_amrgi (a, b, npix) + +int a[ARB], b[ARB] +int npix, i + +# int npix, i, a_first, b_first + +begin +# call zlocva (a, a_first) +# call zlocva (b, b_first) +# +# if (b_first <= a_first) { + do i = 1, npix-1 + b[i] = a[i+1] - a[i] + b[npix] = 0 +# } else { + # overlapping solution not implemented yet! +# } +end diff --git a/pkg/images/imutil/src/imjoin.gx b/pkg/images/imutil/src/imjoin.gx new file mode 100644 index 00000000..3a6dbde7 --- /dev/null +++ b/pkg/images/imutil/src/imjoin.gx @@ -0,0 +1,92 @@ +include + +define VPTR Memi[$1+$2-1] # Array of axis vector pointers + +$for (silrdx) + +# IMJOIN -- Join the set of input images into an output image along the +# specified axis, any dimension. + +procedure imjoin$t (inptr, nimages, out, joindim, outtype) + +pointer inptr[nimages] #I Input IMIO pointers +int nimages #I Number of input images +pointer out #I Output IMIO pointer +int joindim #I Dimension along which to join images +int outtype #I Output datatype + +int i, image, line, nlines, nbands, stat, cum_len +pointer sp, vin, vout, in, inbuf, outbuf + +pointer imgnl$t() +pointer impnl$t() + +begin + # Allocate working space. + call smark (sp) + call salloc (vin, nimages, TY_INT) + call salloc (vout, IM_MAXDIM, TY_LONG) + + # Initialize the v vectors. + call amovkl (long(1), Meml[vout], IM_MAXDIM) + do image = 1, nimages { + call salloc (VPTR(vin,image), IM_MAXDIM, TY_LONG) + call amovkl (long(1), Meml[VPTR(vin,image)], IM_MAXDIM) + } + + # Join input images along the specified dimension. Joins along + # columns and lines require processing in special order, all others + # in the same order. In the first two cases we process all input + # images in inner loops, so we have to keep all those image + # descriptors open. + + switch (joindim) { + case 1: # join columns + nlines = 1 + do i = 2, IM_NDIM(out) + nlines = nlines * IM_LEN(out,i) + do i = 1, nlines { + stat = impnl$t (out, outbuf, Meml[vout]) + cum_len = 0 + do image = 1, nimages { + in = inptr[image] + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf+cum_len], + IM_LEN(in,1)) + cum_len = cum_len + IM_LEN(in,1) + } + } + + case 2: # join lines + nbands = 1 + do i = 3, IM_NDIM(out) + nbands = nbands * IM_LEN(out,i) + do i = 1, nbands { + do image = 1, nimages { + in = inptr[image] + do line = 1, IM_LEN(in,2) { + stat = impnl$t (out, outbuf, Meml[vout]) + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf], IM_LEN(in,1)) + } + } + } + + default: # join bands or higher + do image = 1, nimages { + in = inptr[image] + nlines = 1 + do i = 2, IM_NDIM(in) + nlines = nlines * IM_LEN(in,i) + do i = 1, nlines { + stat = impnl$t (out, outbuf, Meml[vout]) + stat = imgnl$t (in, inbuf, Meml[VPTR(vin,image)]) + call amov$t (Mem$t[inbuf], Mem$t[outbuf], IM_LEN(in,1)) + } + } + } + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/imutil/src/imminmax.x b/pkg/images/imutil/src/imminmax.x new file mode 100644 index 00000000..78daff61 --- /dev/null +++ b/pkg/images/imutil/src/imminmax.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IM_MINMAX -- Compute the minimum and maximum pixel values of an image. +# Works for images of any dimensionality, size, or datatype, although +# the min and max values can currently only be stored in the image header +# as real values. + +procedure im_minmax (im, min_value, max_value) + +pointer im # image descriptor +real min_value # minimum pixel value in image (out) +real max_value # maximum pixel value in image (out) + +pointer buf +bool first_line +long v[IM_MAXDIM] +short minval_s, maxval_s +long minval_l, maxval_l +real minval_r, maxval_r +int imgnls(), imgnll(), imgnlr() + +begin + call amovkl (long(1), v, IM_MAXDIM) # start vector + first_line = true + min_value = INDEF + max_value = INDEF + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (imgnls (im, buf, v) != EOF) { + call alims (Mems[buf], IM_LEN(im,1), minval_s, maxval_s) + if (first_line) { + min_value = minval_s + max_value = maxval_s + first_line = false + } else { + if (minval_s < min_value) + min_value = minval_s + if (maxval_s > max_value) + max_value = maxval_s + } + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im, buf, v) != EOF) { + call aliml (Meml[buf], IM_LEN(im,1), minval_l, maxval_l) + if (first_line) { + min_value = minval_l + max_value = maxval_l + first_line = false + } else { + if (minval_l < min_value) + min_value = minval_l + if (maxval_l > max_value) + max_value = maxval_l + } + } + default: + while (imgnlr (im, buf, v) != EOF) { + call alimr (Memr[buf], IM_LEN(im,1), minval_r, maxval_r) + if (first_line) { + min_value = minval_r + max_value = maxval_r + first_line = false + } else { + if (minval_r < min_value) + min_value = minval_r + if (maxval_r > max_value) + max_value = maxval_r + } + } + } +end diff --git a/pkg/images/imutil/src/imrep.gx b/pkg/images/imutil/src/imrep.gx new file mode 100644 index 00000000..89ce581b --- /dev/null +++ b/pkg/images/imutil/src/imrep.gx @@ -0,0 +1,346 @@ +include +include + +$for (silrdx) + +# IMREP -- Replace pixels in an image between lower and upper by value. + +procedure imrep$t (im, lower, upper, value, img) + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real value # Replacement value +real img # Imaginary value for complex + +pointer buf1, buf2 +int npix, junk +$if (datatype == sil) +real ilower +$endif +PIXEL floor, ceil, newval +long v1[IM_MAXDIM], v2[IM_MAXDIM] +int imgnl$t(), impnl$t() + +$if (datatype == sil) +bool fp_equalr() +$endif + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + npix = IM_LEN(im, 1) + $if (datatype == x) + newval = complex (value, img) + $else + newval = double (value) + $endif + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnl$t (im, buf2, v2) != EOF) + call amovk$t (newval, Mem$t[buf2], npix) + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + $if (datatype == sil) + ceil = int (upper) + $else + ceil = double (upper) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arle$t (Mem$t[buf2], npix, ceil, newval) + } + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + $else + floor = double (lower) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arge$t (Mem$t[buf2], npix, floor, newval) + } + + # Replace pixels between lower and upper by value. + } else { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + $else + floor = double (lower) + ceil = double (upper) + $endif + while (imgnl$t (im, buf1, v1) != EOF) { + junk = impnl$t (im, buf2, v2) + call amov$t (Mem$t[buf1], Mem$t[buf2], npix) + call arep$t (Mem$t[buf2], npix, floor, ceil, newval) + } + } +end + + +# IMRREP -- Replace pixels in an image between lower and upper by value +# and a radius around those pixels. + +procedure imrrep$t (im, lower, upper, radius, value, img) + + +pointer im # Image descriptor +real lower, upper # Range to be replaced +real radius # Radius +real value # Replacement value +real img # Imaginary value for complex + +pointer buf, buf1, buf2, ptr +int i, j, k, l, nc, nl, nradius, nbufs +$if (datatype == sil) +real ilower +$endif +PIXEL floor, ceil, newval, val1, val2 +$if (datatype == x) +real abs_floor, abs_ceil +$endif +real radius2, y2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] # IMIO vectors +int imgnl$t(), impnl$t() +$if (datatype == sil) +bool fp_equalr() +$endif + +begin + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + nc = IM_LEN(im, 1) + if (IM_NDIM(im) > 1) + nl = IM_LEN(im,2) + else + nl = 1 + $if (datatype == x) + newval = complex (value, img) + $else + newval = double (value) + $endif + + # If both lower and upper are INDEF then replace all pixels by value. + if (IS_INDEFR (lower) && IS_INDEFR (upper)) { + while (impnl$t (im, buf2, v2) != EOF) + call amovk$t (newval, Mem$t[buf2], nc) + return + + # If lower is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (lower)) { + $if (datatype == sil) + floor = -MAX_PIXEL + ceil = int (upper) + $else $if (datatype == x) + floor = 0 + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = -MAX_PIXEL + ceil = double (upper) + $endif $endif + + # If upper is INDEF then all pixels below upper are replaced by value. + } else if (IS_INDEFR (upper)) { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = MAX_PIXEL + $else $if (datatype == x) + floor = real (lower) + ceil = MAX_REAL + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = double (lower) + ceil = MAX_PIXEL + $endif $endif + + # Replace pixels between lower and upper by value. + } else { + $if (datatype == sil) + ilower = int (lower) + if (fp_equalr(lower,ilower)) + floor = int (lower) + else + floor = int (lower+1.0) + ceil = int (upper) + $else $if (datatype == x) + floor = real (lower) + ceil = real (upper) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $else + floor = double (lower) + ceil = double (upper) + $endif $endif + } + + # Initialize buffering. + radius2 = radius * radius + nradius = int (radius) + nbufs = min (1 + 2 * nradius, nl) + call calloc (buf, nc*nbufs, TY_PIXEL) + + while (imgnl$t (im, buf1, v1) != EOF) { + j = v1[2] - 1 + buf2 = buf + mod (j, nbufs) * nc + do i = 1, nc { + val1 = Mem$t[buf1] + val2 = Mem$t[buf2] + $if (datatype == x) + if ((abs (val1) >= abs_floor) && (abs (val1) <= abs_ceil)) { + $else + if ((val1 >= floor) && (val1 <= ceil)) { + $endif + do k = max(1,j-nradius), min (nl,j+nradius) { + ptr = buf + mod (k, nbufs) * nc - 1 + y2 = (k - j) ** 2 + do l = max(1,i-nradius), min (nc,i+nradius) { + if ((l-i)**2 + y2 > radius2) + next + Mem$t[ptr+l] = INDEF + } + } + } else { + if (!IS_INDEF(val2)) + Mem$t[buf2] = val1 + } + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + + if (j > nradius) { + while (impnl$t (im, buf2, v2) != EOF) { + k = v2[2] - 1 + buf1 = buf + mod (k, nbufs) * nc + do i = 1, nc { + val1 = Mem$t[buf1] + if (IS_INDEF(Mem$t[buf1])) + Mem$t[buf2] = newval + else + Mem$t[buf2] = val1 + Mem$t[buf1] = 0. + buf1 = buf1 + 1 + buf2 = buf2 + 1 + } + if (j != nl) + break + } + } + } + + call mfree (buf, TY_PIXEL) +end + + +# AREP -- Replace array values which are between floor and ceil by value. + +procedure arep$t (a, npts, floor, ceil, newval) + +PIXEL a[npts] # Input arrays +int npts # Number of points +PIXEL floor, ceil # Replacement limits +PIXEL newval # Replacement value + +int i +$if (datatype == x) +real abs_floor +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + abs_ceil = abs (ceil) + $endif + + do i = 1, npts { + $if (datatype == x) + if ((abs (a[i]) >= abs_floor) && (abs (a[i]) <= abs_ceil)) + $else + if ((a[i] >= floor) && (a[i] <= ceil)) + $endif + a[i] = newval + } +end + + +# ARLE -- If A[i] is less than or equal to FLOOR replace by NEWVAL. + +procedure arle$t (a, npts, floor, newval) + +PIXEL a[npts] +int npts +PIXEL floor, newval + +int i +$if (datatype == x) +real abs_floor +$endif + +begin + $if (datatype == x) + abs_floor = abs (floor) + $endif + + do i = 1, npts + $if (datatype == x) + if (abs (a[i]) <= abs_floor) + $else + if (a[i] <= floor) + $endif + a[i] = newval +end + + +# ARGE -- If A[i] is greater than or equal to CEIL replace by NEWVAL. + +procedure arge$t (a, npts, ceil, newval) + +PIXEL a[npts] +int npts +PIXEL ceil, newval + +int i +$if (datatype == x) +real abs_ceil +$endif + +begin + $if (datatype == x) + abs_ceil = abs (ceil) + $endif + + do i = 1, npts + $if (datatype == x) + if (abs (a[i]) >= abs_ceil) + $else + if (a[i] >= ceil) + $endif + a[i] = newval +end + +$endfor diff --git a/pkg/images/imutil/src/imstat.h b/pkg/images/imutil/src/imstat.h new file mode 100644 index 00000000..b059bc31 --- /dev/null +++ b/pkg/images/imutil/src/imstat.h @@ -0,0 +1,62 @@ +# Header file for the IMSTATISTTICS task. + +define LEN_IMSTAT 20 + +define IST_SUMX Memd[P2D($1)] +define IST_SUMX2 Memd[P2D($1+2)] +define IST_SUMX3 Memd[P2D($1+4)] +define IST_SUMX4 Memd[P2D($1+6)] +define IST_LO Memr[P2R($1+8)] +define IST_HI Memr[P2R($1+9)] +define IST_MIN Memr[P2R($1+10)] +define IST_MAX Memr[P2R($1+11)] +define IST_MEAN Memr[P2R($1+12)] +define IST_MEDIAN Memr[P2R($1+13)] +define IST_MODE Memr[P2R($1+14)] +define IST_STDDEV Memr[P2R($1+15)] +define IST_SKEW Memr[P2R($1+16)] +define IST_KURTOSIS Memr[P2R($1+17)] +define IST_NPIX Memi[$1+18] +define IST_SW Memi[$1+19] + +define LEN_NSWITCHES 8 + +define IST_SKURTOSIS Memi[$1] +define IST_SSKEW Memi[$1+1] +define IST_SSTDDEV Memi[$1+2] +define IST_SMODE Memi[$1+3] +define IST_SMEDIAN Memi[$1+4] +define IST_SMEAN Memi[$1+5] +define IST_SMINMAX Memi[$1+6] +define IST_SNPIX Memi[$1+7] + +define IST_FIELDS "|image|npix|min|max|mean|midpt|mode|stddev|skew|kurtosis|" + +define IST_NFIELDS 10 + +define IST_KIMAGE "IMAGE" +define IST_KNPIX "NPIX" +define IST_KMIN "MIN" +define IST_KMAX "MAX" +define IST_KMEAN "MEAN" +define IST_KMEDIAN "MIDPT" +define IST_KMODE "MODE" +define IST_KSTDDEV "STDDEV" +define IST_KSKEW "SKEW" +define IST_KKURTOSIS "KURTOSIS" + +define IST_FIMAGE 1 +define IST_FNPIX 2 +define IST_FMIN 3 +define IST_FMAX 4 +define IST_FMEAN 5 +define IST_FMEDIAN 6 +define IST_FMODE 7 +define IST_FSTDDEV 8 +define IST_FSKEW 9 +define IST_FKURTOSIS 10 + +define IST_FCOLUMN "%10d" +define IST_FINTEGER "%10d" +define IST_FREAL "%10.4g" +define IST_FSTRING "%20s" diff --git a/pkg/images/imutil/src/imsum.gx b/pkg/images/imutil/src/imsum.gx new file mode 100644 index 00000000..31afc420 --- /dev/null +++ b/pkg/images/imutil/src/imsum.gx @@ -0,0 +1,398 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../imsum.h" + +define TMINSW 1.00 # Relative timings for nvecs = 5 +define TMXMNSW 1.46 +define TMED3 0.18 +define TMED5 0.55 + +# IMSUM -- Sum or average images with optional high and low pixel rejection. +# +# This procedure has to be clever in not exceeding the maximum number of images +# which can be mapped at one time. If no pixels are being rejected then the +# images can be summed (or averaged) in blocks using the output image to hold +# intermediate results. If pixels are being rejected then lines from all +# images must be obtained. If the number of images exceeds the maximum +# then only a subset of the images are kept mapped and the remainder are +# mapped and unmapped for each line. This, of course, is inefficient but +# there is no other way. + +$for(silrd) +procedure imsum$t (list, output, im_out, nlow, nhigh, option) + +int list # List of input images +char output[ARB] # Output image +pointer im_out # Output image pointer +int nlow # Number of low pixels to reject +int nhigh # Number of high pixels to reject +char option[ARB] # Output option + +int i, n, nimages, naccept, npix, ndone, pass +PIXEL const +pointer sp, input, v1, v2, im, buf, buf1, buf_in, buf_out + +bool streq() +int imtlen(), imtgetim(), imtrgetim() +pointer immap(), imgnl$t(), impnl$t() +errchk immap, imunmap, imgnl$t, impnl$t + +begin + # Initialize. + nimages = imtlen (list) + naccept = nimages - nlow - nhigh + const = naccept + npix = IM_LEN(im_out, 1) + if (naccept < 1) + call error (0, "Number of rejected pixels is too large") + + # Allocate memory. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + call salloc (im, nimages, TY_INT) + + # If there are no pixels to be rejected avoid calls to reject pixels + # and do the operation in blocks so that the number of images mapped + # does not exceed the maximum. The output image is used to + # store intermediate results. + + if ((nlow == 0) && (nhigh == 0)) { + pass = 0 + ndone = 0 + repeat { + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX) + break + } + ndone = ndone + n + + pass = pass + 1 + if (pass > 1) { + call imunmap (im_out) + im_out = immap (output, READ_WRITE, 0) + } + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # For each input line compute an output line. + while (impnl$t (im_out, buf_out, Meml[v2]) != EOF) { + + # Clear the output buffer during the first pass and + # read in the partial sum from the output image during + # subsequent passes. + + if (pass == 1) + call aclr$t (Mem$t[buf_out], npix) + else { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (im_out, buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call amov$t (Mem$t[buf_in], Mem$t[buf_out], npix) + } + + # Accumulate lines from each input image. + do i = 1, n { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + call aadd$t (Mem$t[buf_in], Mem$t[buf_out], + Mem$t[buf_out], npix) + } + + # If all images have been accumulated and averaging then + # divide by the number of images. + if ((ndone == nimages) && streq (option, "average")) + call adivk$t (Mem$t[buf_out], const, Mem$t[buf_out], + npix) + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + do i = 1, n + call imunmap (Memi[im+i-1]) + } until (ndone == nimages) + + # Finish up. + call sfree (sp) + return + } + + + # Map the input images up to the maximum allowed. The remainder + # will be mapped during each line. + n = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + Memi[im+n] = immap (Memc[input], READ_ONLY, 0) + n = n + 1 + if (n == IMS_MAX - 1) + break + } + + # Allocate additional buffer space. + call salloc (buf, nimages, TY_INT) + if (nimages - n > 0) + call salloc (buf1, (nimages-n)*npix, TY_PIXEL) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + + # Compute output lines for each input line. + while (impnl$t (im_out, buf_out, Meml[v2]) != EOF) { + + # Read lines from the images which remain open. + for (i = 1; i <= n; i = i + 1) { + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], Memi[buf+i-1], Meml[v2]) == EOF) + call error (0, "Error reading input image") + } + + # For all additional images map the image, read a line, copy the + # data to a buffer since the image buffer is reused, and unmap + # the image. + for (; i <= nimages; i = i + 1) { + if (imtrgetim (list, i, Memc[input], SZ_FNAME) == EOF) + break + Memi[im+i-1] = immap (Memc[input], READ_ONLY, 0) + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + if (imgnl$t (Memi[im+i-1], buf_in, Meml[v2]) == EOF) + call error (0, "Error reading input image") + Memi[buf+i-1] = buf1 + (i - n - 1) * npix + call amov$t (Mem$t[buf_in], Mem$t[Memi[buf+i-1]], npix) + call imunmap (Memi[im+i-1]) + } + + # Reject pixels. + call imrej$t (Memi[buf], nimages, Mem$t[buf_out], npix, nlow, nhigh) + + # If averaging divide the sum by the number of images averaged. + if ((naccept > 1) && streq (option, "average")) { + const = naccept + call adivk$t (Mem$t[buf_out], const, Mem$t[buf_out], npix) + } + + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + } + + # Finish up. + do i = 1, n + call imunmap (Memi[im+i-1]) + call sfree (sp) +end + + +# IMREJ -- Reject the number of high and low points and sum the rest. + +procedure imrej$t (a, nvecs, b, npts, nlow, nhigh) + +pointer a[nvecs] # Pointers to set of vectors +int nvecs # Number of vectors +PIXEL b[npts] # Output vector +int npts # Number of points in the vectors +int nlow # Number of low points to be rejected +int nhigh # Number of high points to be rejected + +int i, j +int naccept, minrej, npairs, nlow1, nhigh1 +real tmedian, time1, time2 + +begin + naccept = nvecs - nlow - nhigh + + # If no points are rejected return the sum. + + if (naccept == nvecs) { + call amov$t (Mem$t[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + return + } + + minrej = min (nlow, nhigh) + npairs = minrej + nlow1 = nlow - npairs + nhigh1 = nhigh - npairs + + if ((naccept == 1) && (npairs > 0)) { + if (npairs == 1) { + tmedian = TMED3 + npairs = npairs - 1 + } else { + tmedian = TMED5 + npairs = npairs - 2 + } + } else + tmedian = 0 + + # Compare the time required to reject the minimum number + # of low or high points and extract the number of points to accept + # with the time to reject pairs and the excess number of low or + # high points to either reach a median of 3 or 5 points or isolate + # the acceptable points. + + time1 = TMINSW * (minrej + naccept) + time2 = tmedian + TMXMNSW * npairs + TMINSW * (nlow1 + nhigh1) + + i = nvecs + if (time1 < time2) { + + # Sort the nlow and naccept points + if (nlow < nhigh) { + for (j = 1; j <= nlow + naccept; j = j + 1) { + call minsw$t (a, i, npts) + i = i - 1 + } + call amov$t (Mem$t[a[nhigh+1]], b, npts) + for (j = nhigh+2; j <= nhigh+naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + + # Sort the nhigh and naccept points + } else { + for (j = 1; j <= nhigh + naccept; j = j + 1) { + call maxsw$t (a, i, npts) + i = i - 1 + } + call amov$t (Mem$t[a[nlow+1]], b, npts) + for (j = nlow+2; j <= nlow+naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + } + + } else { + # Reject the npairs low and high points. + for (j = 1; j <= npairs; j = j + 1) { + call mxmnsw$t (a, i, npts) + i = i - 2 + } + # Reject the excess low points. + for (j = 1; j <= nlow1; j = j + 1) { + call minsw$t (a, i, npts) + i = i - 1 + } + # Reject the excess high points. + for (j = 1; j <= nhigh1; j = j + 1) { + call maxsw$t (a, i, npts) + i = i - 1 + } + + # Check if the remaining points constitute a 3 or 5 point median + # or the set of desired points. + if (tmedian == 0.) { + call amov$t (Mem$t[a[1]], b, npts) + for (j = 2; j <= naccept; j = j + 1) + call aadd$t (Mem$t[a[j]], b, b, npts) + } else if (tmedian == TMED3) { + call amed3$t (Mem$t[a[1]], Mem$t[a[2]], Mem$t[a[3]], b, npts) + } else { + call amed5$t (Mem$t[a[1]], Mem$t[a[2]], Mem$t[a[3]], + Mem$t[a[4]], Mem$t[a[5]], b, npts) + } + } +end + + +# MINSW -- Given an array of vector pointers for each element in the vectors +# swap the minimum element with that of the last vector. + +procedure minsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmin +PIXEL temp + +begin + do i = 0, npts - 1 { + kmin = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] < Mem$t[kmin]) + kmin = k + } + if (k != kmin) { + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmin] + Mem$t[kmin] = temp + } + } +end + + +# MAXSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector. + +procedure maxsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax +PIXEL temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] > Mem$t[kmax]) + kmax = k + } + if (k != kmax) { + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmax] + Mem$t[kmax] = temp + } + } +end + + +# MXMNSW -- Given an array of vector pointers for each element in the vectors +# swap the maximum element with that of the last vector and the minimum element +# with that of the next to last vector. The number of vectors must be greater +# than 1. + +procedure mxmnsw$t (a, nvecs, npts) + +pointer a[nvecs] # Array of vector pointers +int nvecs # Number of vectors +int npts # Number of points in the vectors + +int i, j, k, kmax, kmin +PIXEL temp + +begin + do i = 0, npts - 1 { + kmax = a[1] + i + kmin = kmax + do j = 2, nvecs { + k = a[j] + i + if (Mem$t[k] > Mem$t[kmax]) + kmax = k + else if (Mem$t[k] < Mem$t[kmin]) + kmin = k + } + temp = Mem$t[k] + Mem$t[k] = Mem$t[kmax] + Mem$t[kmax] = temp + if (kmin == k) { + j = a[nvecs - 1] + i + temp = Mem$t[j] + Mem$t[j] = Mem$t[kmax] + Mem$t[kmax] = temp + } else { + j = a[nvecs - 1] + i + temp = Mem$t[j] + Mem$t[j] = Mem$t[kmin] + Mem$t[kmin] = temp + } + } +end +$endfor diff --git a/pkg/images/imutil/src/imsum.h b/pkg/images/imutil/src/imsum.h new file mode 100644 index 00000000..190d277c --- /dev/null +++ b/pkg/images/imutil/src/imsum.h @@ -0,0 +1,4 @@ +# Definitions for IMSUM + +define IMS_MAX 15 # Maximum number of images which are mapped + # at the same time. diff --git a/pkg/images/imutil/src/imtile.h b/pkg/images/imutil/src/imtile.h new file mode 100644 index 00000000..a2610860 --- /dev/null +++ b/pkg/images/imutil/src/imtile.h @@ -0,0 +1,55 @@ +# Header file for the IMTILE task. + +# Define the structure + +define LEN_IRSTRUCT 35 + +define IT_NCOLS Memi[$1] # x length of single subraster +define IT_NROWS Memi[$1+1] # y length of a single subrasters +define IT_NXOVERLAP Memi[$1+2] # x overlap between subrasters +define IT_NYOVERLAP Memi[$1+3] # y overlap between subrasters +define IT_NXSUB Memi[$1+4] # number of subrasters in x dimension +define IT_NYSUB Memi[$1+5] # number of subrasters in y dimension +define IT_NXRSUB Memi[$1+6] # x index of reference subraster +define IT_NYRSUB Memi[$1+7] # y index of reference subraster +define IT_XREF Memi[$1+8] # x offset of reference subraster +define IT_YREF Memi[$1+9] # y offset of reference subraster +define IT_CORNER Memi[$1+10] # starting corner for insertion +define IT_ORDER Memi[$1+11] # row or column insertion +define IT_RASTER Memi[$1+12] # raster order +define IT_OVAL Memr[P2R($1+13)] # undefined value + +define IT_IC1 Memi[$1+14] # input image lower column limit +define IT_IC2 Memi[$1+15] # input image upper column limit +define IT_IL1 Memi[$1+16] # input image lower line limit +define IT_IL2 Memi[$1+17] # input image upper line limit +define IT_OC1 Memi[$1+18] # output image lower column limit +define IT_OC2 Memi[$1+19] # output image upper column limit +define IT_OL1 Memi[$1+20] # output image lower line limit +define IT_OL2 Memi[$1+21] # output image upper line limit +define IT_DELTAX Memi[$1+22] # x shifts +define IT_DELTAY Memi[$1+23] # y shifts +define IT_DELTAI Memi[$1+24] # intensity shifts + +define IT_XRSHIFTS Memi[$1+25] # x row links +define IT_YRSHIFTS Memi[$1+26] # y row links +define IT_NRSHIFTS Memi[$1+27] # number of row links +define IT_XCSHIFTS Memi[$1+28] # x column links +define IT_YCSHIFTS Memi[$1+29] # y column links +define IT_NCSHIFTS Memi[$1+30] # number of column links + +# Define some useful constants + +define IT_LL 1 +define IT_LR 2 +define IT_UL 3 +define IT_UR 4 + +define IT_ROW 1 +define IT_COLUMN 2 + +define IT_COORDS 1 +define IT_SHIFTS 2 +define IT_FILE 3 + +define MAX_NRANGES 100 diff --git a/pkg/images/imutil/src/listpixels.x b/pkg/images/imutil/src/listpixels.x new file mode 100644 index 00000000..e4435c95 --- /dev/null +++ b/pkg/images/imutil/src/listpixels.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# LISTPIXELS -- Convert image pixels into a text stream, i.e., into a list. +# Each pixel is printed on a separate line, preceded by its coordinates. +# The images or image sections may be of any dimension. + +procedure t_listpixels() + +bool verbose +char image[SZ_FNAME], wcs[SZ_FNAME] +double incoords[IM_MAXDIM], outcoords[IM_MAXDIM] +int i, j, npix, ndim, wcsndim, laxis1, fmtstat +int paxno[IM_MAXDIM], laxno[IM_MAXDIM] +long v[IM_MAXDIM], vcoords[IM_MAXDIM] +pointer im, line, imlist, mw, ct, fmtptrs[IM_MAXDIM] + +bool clgetb() +int imgnlr(), imgnld(), imgnlx(), imtgetim(), mw_stati(), clscan(), nscan() +pointer imtopenp(), immap(), mw_openim(), mw_sctran() + +begin + # Get the image list and the wcs. + imlist = imtopenp ("images") + call clgstr ("wcs", wcs, SZ_FNAME) + if (wcs[1] == EOS) + call strcpy ("logical", wcs, SZ_FNAME) + verbose = clgetb ("verbose") + + while (imtgetim (imlist, image, SZ_FNAME) != EOF) { + # Print optional banner string. + if (verbose) { + call printf ("\n#Image: %s Wcs: %s\n\n") + call pargstr (image) + call pargstr (wcs) + } + + # Open the input image. + im = immap (image, READ_ONLY, 0) + ndim = IM_NDIM(im) + npix = IM_LEN(im,1) + + # Get the wcs. + ifnoerr (mw = mw_openim (im)) { + # Set up the transformation. + call mw_seti (mw, MW_USEAXMAP, NO) + ct = mw_sctran (mw, "logical", wcs, 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + # Get the physical to logical axis map. + call mw_gaxmap (mw, paxno, laxno, wcsndim) + + # Set the default wcs. + call mw_ssytem (mw, wcs) + + } else { + # Print the error message from the above loop. + call erract (EA_WARN) + + # Set the transform to the identity transform. + mw = NULL + ct = NULL + wcsndim = ndim + + # Set the default physical to logical axis map. + do i = 1, wcsndim + paxno[i] = i + } + + # Initialize the v vectors. + call amovkl (long (1), v, IM_MAXDIM) + call amovkl (long (1), vcoords, IM_MAXDIM) + + # Initialize the coordinates. + laxis1 = 0 + do i = 1, wcsndim { + if (paxno[i] == 0) { + incoords[i] = 1 + } else if (paxno[i] == 1) { + laxis1 = i + incoords[i] = v[1] + } else { + incoords[i] = v[paxno[i]] + } + } + + # Check and correct for the no axis mapping case. + if (laxis1 == 0) { + laxis1 = 1 + do i = 1, wcsndim + paxno[i] = i + } + + # Get the logical to physical axis map for the format strings. + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + + # Set the format strings for the logical axes. + fmtstat = clscan ("formats") + do i = 1, ndim { + call malloc (fmtptrs[i], SZ_FNAME, TY_CHAR) + if (fmtstat != EOF) + call gargwrd (Memc[fmtptrs[i]], SZ_FNAME) + else + Memc[fmtptrs[i]] = EOS + if ((nscan() == i) && (Memc[fmtptrs[i]] != EOS)) + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + else if (laxno[i] == 0) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else if (mw == NULL || ct == NULL) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else iferr (call mw_gwattrs (mw, laxno[i], "format", + Memc[fmtptrs[i]], SZ_FNAME)) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + } + + # Print the pixels. + switch (IM_PIXTYPE(im)) { + case TY_COMPLEX: + while (imgnlx (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %z\n") # pixel value + call pargx (Memx[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + case TY_DOUBLE: + while (imgnld (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargd (Memd[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + default: + while (imgnlr (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargr (Memr[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + } + + do i = 1, ndim + call mfree (fmtptrs[i], TY_CHAR) + if (mw != NULL) + call mw_close (mw) + call imunmap (im) + } + + call imtclose (imlist) +end diff --git a/pkg/images/imutil/src/minmax.x b/pkg/images/imutil/src/minmax.x new file mode 100644 index 00000000..c3dcbfff --- /dev/null +++ b/pkg/images/imutil/src/minmax.x @@ -0,0 +1,313 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IM_VMINMAX -- Compute the minimum and maximum pixel values of an image. +# Works for images of any dimensionality, size, or datatype, although +# the min and max values can currently only be stored in the image header +# as real values. + +procedure im_vminmax (im, min_value, max_value, imin_value, imax_value, + vmin, vmax) + +pointer im # image descriptor +double min_value # minimum pixel value in image (real, out) +double max_value # maximum pixel value in image (real, out) +double imin_value # minimum pixel value in image (imag, out) +double imax_value # maximum pixel value in image (imag, out) +long vmin[ARB], vmax[ARB] # v vectors + +bool first_line +int colmin, colmax +complex xmin_value, xmax_value, minval_x, maxval_x +long v[IM_MAXDIM], ovmin[IM_MAXDIM], ovmax[IM_MAXDIM] +short minval_s, maxval_s +long minval_l, maxval_l +pointer buf +real minval_r, maxval_r +double minval_d, maxval_d +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() + +begin + call amovkl (long(1), v, IM_MAXDIM) # start vector + call amovkl (long(1), ovmin, IM_MAXDIM) + call amovkl (long(1), ovmax, IM_MAXDIM) + call amovkl (long(1), vmin, IM_MAXDIM) + call amovkl (long(1), vmax, IM_MAXDIM) + + first_line = true + min_value = INDEFD + max_value = INDEFD + imin_value = INDEFD + imax_value = INDEFD + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + while (imgnls (im, buf, v) != EOF) { + call valims (Mems[buf], IM_LEN(im,1), minval_s, maxval_s, + colmin, colmax) + if (first_line) { + min_value = minval_s + max_value = maxval_s + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_s < min_value) { + min_value = minval_s + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_s > max_value) { + max_value = maxval_s + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im, buf, v) != EOF) { + call valiml (Meml[buf], IM_LEN(im,1), minval_l, maxval_l, + colmin, colmax) + if (first_line) { + min_value = minval_l + max_value = maxval_l + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_l < min_value) { + min_value = minval_l + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_l > max_value) { + max_value = maxval_l + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_REAL: + while (imgnlr (im, buf, v) != EOF) { + call valimr (Memr[buf], IM_LEN(im,1), minval_r, maxval_r, + colmin, colmax) + if (first_line) { + min_value = minval_r + max_value = maxval_r + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_r < min_value) { + min_value = minval_r + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_r > max_value) { + max_value = maxval_r + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_DOUBLE: + while (imgnld (im, buf, v) != EOF) { + call valimd (Memd[buf], IM_LEN(im,1), minval_d, maxval_d, + colmin, colmax) + if (first_line) { + min_value = minval_d + max_value = maxval_d + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (minval_d < min_value) { + min_value = minval_d + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (maxval_d > max_value) { + max_value = maxval_d + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + case TY_COMPLEX: + while (imgnlx (im, buf, v) != EOF) { + call valimx (Memx[buf], IM_LEN(im,1), minval_x, maxval_x, + colmin, colmax) + if (first_line) { + xmin_value = minval_x + xmax_value = maxval_x + vmin[1] = colmin + vmax[1] = colmax + first_line = false + } else { + if (abs (minval_x) < abs (xmin_value)) { + xmin_value = minval_x + vmin[1] = colmin + call amovl (ovmin[2], vmin[2], IM_NDIM(im) - 1) + } + if (abs (maxval_x) > abs (xmax_value)) { + xmax_value = maxval_x + vmax[1] = colmax + call amovl (ovmax[2], vmax[2], IM_NDIM(im) - 1) + } + } + call amovl (v[2], ovmin[2], IM_NDIM(im) - 1) + call amovl (v[2], ovmax[2], IM_NDIM(im) - 1) + } + + min_value = real (xmin_value) + max_value = real (xmax_value) + imin_value = aimag (xmin_value) + imax_value = aimag (xmax_value) + + default: + call error (0, "Unknown pixel data type") + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valims (a, npix, minval_s, maxval_s, colmin, colmax) + +short a[ARB], minval_s, maxval_s, value +int colmin, colmax, npix, i + +begin + minval_s = a[1] + maxval_s = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_s) { + minval_s = value + colmin = i + } else if (value > maxval_s) { + maxval_s = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valiml (a, npix, minval_l, maxval_l, colmin, colmax) + +long a[ARB], minval_l, maxval_l, value +int colmin, colmax, npix, i + +begin + minval_l = a[1] + maxval_l = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_l) { + minval_l = value + colmin = i + } else if (value > maxval_l) { + maxval_l = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimr (a, npix, minval_r, maxval_r, colmin, colmax) + +real a[ARB], minval_r, maxval_r, value +int colmin, colmax, npix, i + +begin + minval_r = a[1] + maxval_r = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_r) { + minval_r = value + colmin = i + } else if (value > maxval_r) { + maxval_r = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimd (a, npix, minval_d, maxval_d, colmin, colmax) + +double a[ARB], minval_d, maxval_d, value +int colmin, colmax, npix, i + +begin + minval_d = a[1] + maxval_d = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (value < minval_d) { + minval_d = value + colmin = i + } else if (value > maxval_d) { + maxval_d = value + colmax = i + } + } +end + + +# ALIM -- Compute the limits (minimum and maximum values) of a vector. + +procedure valimx (a, npix, minval_x, maxval_x, colmin, colmax) + +complex a[ARB], minval_x, maxval_x, value +int colmin, colmax, npix, i + +begin + minval_x = a[1] + maxval_x = a[1] + colmin = 1 + colmax = 1 + + do i = 1, npix { + value = a[i] + if (abs (value) < abs (minval_x)) { + minval_x = value + colmin = i + } else if (abs (value) > abs (maxval_x)) { + maxval_x = value + colmax = i + } + } +end diff --git a/pkg/images/imutil/src/mkpkg b/pkg/images/imutil/src/mkpkg new file mode 100644 index 00000000..7fdbfbb3 --- /dev/null +++ b/pkg/images/imutil/src/mkpkg @@ -0,0 +1,81 @@ +# Library for making the IMUTIL tasks + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (imexpr.x, imexpr.gx) + $(GEN) imexpr.gx -o imexpr.x $endif + + $ifolder (generic/imfuncs.x, imfuncs.gx) + $(GEN) imfuncs.gx -o generic/imfuncs.x $endif + + $ifolder (generic/imjoin.x, imjoin.gx) + $(GEN) imjoin.gx -o generic/imjoin.x $endif + + $ifolder (generic/imrep.x, imrep.gx) + $(GEN) imrep.gx -o generic/imrep.x $endif + + $ifolder (generic/imsum.x, imsum.gx) + $(GEN) imsum.gx -o generic/imsum.x $endif + + $ifolder (generic/imaadd.x, imaadd.gx) + $(GEN) imaadd.gx -o generic/imaadd.x $endif + $ifolder (generic/imadiv.x, imadiv.gx) + $(GEN) imadiv.gx -o generic/imadiv.x $endif + $ifolder (generic/imamax.x, imamax.gx) + $(GEN) imamax.gx -o generic/imamax.x $endif + $ifolder (generic/imamin.x, imamin.gx) + $(GEN) imamin.gx -o generic/imamin.x $endif + $ifolder (generic/imamul.x, imamul.gx) + $(GEN) imamul.gx -o generic/imamul.x $endif + $ifolder (generic/imasub.x, imasub.gx) + $(GEN) imasub.gx -o generic/imasub.x $endif + $ifolder (generic/imanl.x, imanl.gx) + $(GEN) imanl.gx -o generic/imanl.x $endif + + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic + + getcmd.x + gettok.x gettok.h + hedit.x + imdelete.x + imexpr.x \ + gettok.h + iegsym.x \ + gettok.h + imfunction.x + imgets.x + imheader.x \ + + imhistogram.x + imminmax.x + listpixels.x + minmax.x + nhedit.x + t_imstat.x "imstat.h" + t_sections.x + hselect.x + t_imarith.x + t_imaxes.x + t_chpix.x + t_imcopy.x + t_imdivide.x + t_imjoin.x + t_imrename.x + t_imreplace.x + t_imslice.x + t_imsum.x + t_imstack.x + t_imtile.x "imtile.h" + t_minmax.x + ; diff --git a/pkg/images/imutil/src/nhedit.x b/pkg/images/imutil/src/nhedit.x new file mode 100644 index 00000000..1e9300c1 --- /dev/null +++ b/pkg/images/imutil/src/nhedit.x @@ -0,0 +1,1101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name +define HRECLEN 80 + +define OP_EDIT 1 # hedit opcodes +define OP_INIT 2 +define OP_ADD 3 +define OP_DELETE 4 +define OP_DEFPAR 5 +define OP_RENAME 6 +define BEFORE 1 +define AFTER 2 + + +# NHEDIT -- Edit or view selected fields of an image header or headers. This +# editor performs a single edit operation upon a relation, e.g., upon a set +# of fields of a set of images. Templates and expressions may be used to +# automatically select the images and fields to be edited, and to compute +# the new value of each field. + +procedure t_nhedit() + +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) + +bool noupdate, quit +int imlist, nfields, up, min_lenuserarea +pointer sp, field, comment, sections, im, ip, image, buf +pointer cmd, pkey +int operation, verify, show, update, fd, baf +int dp_oper, dp_update, dp_verify, dp_show + +pointer immap() +bool streq() +int imtopenp(), imtgetim(), getline(), nowhite() +int envfind(), ctoi(), open() + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (fields, SZ_FNAME, TY_CHAR) + call salloc (pkey, SZ_FNAME, TY_CHAR) + call salloc (valexpr, SZ_LINE, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + call salloc (sections, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the primary operands. + imlist = imtopenp ("images") + + # Determine type of operation to be performed (default is edit). + + # Do we have a command file instead of a command line? Allow either + # a null string or the string "NULL" to indicate we don't. + + call clgstr ("comfile", Memc[fields], SZ_LINE) + if (nowhite (Memc[fields], Memc[fields], SZ_LINE) == 0 || + streq (Memc[fields], "NULL")) { + call he_getpars (operation, fields, valexpr, Memc[comment], + Memc[pkey], baf, update, verify, show) + fd = 0 + } else { + call he_getpars (dp_oper, NULL, valexpr, Memc[comment], + Memc[pkey], baf, dp_update, dp_verify, dp_show) + fd = open(Memc[fields], READ_ONLY, TEXT_FILE) + } + + # Main processing loop. An image is processed in each pass through + # the loop. + + while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) { + + # set the length of the user area + if (envfind ("min_lenuserarea", Memc[sections], SZ_FNAME) > 0) { + up = 1 + if (ctoi (Memc[sections], up, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Open the image. + iferr { + if (update == YES || fd != 0) + im = immap (Memc[image], READ_WRITE, min_lenuserarea) + else + im = immap (Memc[image], READ_ONLY, min_lenuserarea) + } then { + call erract (EA_WARN) + next + } + + if (fd != 0) { + # Open the command file and start processing each line. + # rewind file before proceeding + + call seek(fd, BOF) + while (getline(fd, Memc[cmd]) != EOF) { + for (ip=cmd; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[cmd] == '#' || Memc[ip] == '\n') + next + + call he_getcmdf (Memc[cmd], operation, Memc[fields], + Memc[valexpr], Memc[comment], Memc[pkey], baf, + update, verify, show) + + # Set the default parameters for the command file. + if (operation < 0) { + dp_oper = -operation + if (update != -1) + dp_update = update + if (verify != -1) + dp_verify = verify + if (show != -1) + dp_show = show + next + } + + # Set the parameters for the current command, the + # command parameters take precedence over the defaults. + call nh_setpar (operation, dp_oper, dp_update, + dp_verify, dp_show, update, verify, show) + + iferr (call nh_edit (im, Memc[image], operation, + Memc[fields], Memc[valexpr], Memc[comment], + Memc[pkey], baf, update, verify, show, nfields)) + call erract (EA_WARN) + + } + + } else + iferr (call nh_edit (im, Memc[image], operation, Memc[fields], + Memc[valexpr], Memc[comment], Memc[pkey], baf, update, + verify, show, nfields)) + call erract (EA_WARN) + + # Update the image header and unmap the image. + + noupdate = false + quit = false + + if (update == YES) { + if (nfields == 0 && fd == 0) + noupdate = true + else if (verify == YES) { + call eprintf ("update %s ? (yes): ") + call pargstr (Memc[image]) + call flush (STDERR) + + if (getline (STDIN, Memc[buf]) == EOF) + noupdate = true + else { + # Strip leading whitespace and trailing newline. + for (ip=buf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == 'q') { + quit = true + noupdate = true + } else if (! (Memc[ip] == '\n' || Memc[ip] == 'y')) + noupdate = true + } + } + + if (noupdate) { + call imseti (im, IM_WHEADER, NO) + call imunmap (im) + } else { + call imunmap (im) + if (show == YES) { + call printf ("%s updated\n") + call pargstr (Memc[image]) + } + } + } else { + call imunmap (im) + } + + call flush (STDOUT) + if (quit) + break + } #end of while + + # Close command file + if (fd != 0) + call close(fd) + call imtclose (imlist) + call sfree (sp) +end + + +# NH_EDIT -- Edit the field in the image header. + +procedure nh_edit (im, image, operation, keyws, exprs, comment, pkey, baf, + update, verify, show, nfields) + +pointer im #I image descriptor +char image[ARB] # +int operation #I operation code +char keyws[ARB] # Memc[fields] +char exprs[ARB] # Memc[valexpr] +char comment[ARB] # Memc[comment] +char pkey[ARB] # +int baf +int update +int verify +int show +int nfields + +pointer sp, field +int imgnfn(), imofnlu() +int flist + +begin + + call smark(sp) + call salloc (field, SZ_FNAME, TY_CHAR) + + if (operation == OP_INIT || operation == OP_ADD) { + # Add a field to the image header. This cannot be done within + # the IMGNFN loop because template expansion on the existing + # fields of the image header would discard the new field name + # since it does not yet exist. + + nfields = 1 + call he_getopsetimage (im, image, keyws) + switch (operation) { + case OP_INIT: + call nh_initfield (im, image, keyws, exprs, comment, + pkey, baf, verify, show, update) + case OP_ADD: + call nh_addfield (im, image, keyws, exprs, comment, + pkey, baf, verify, show, update) + } + } else { + # Open list of fields to be processed. + flist = imofnlu (im, keyws) + nfields = 0 + while (imgnfn (flist, Memc[field], SZ_FNAME) != EOF) { + call he_getopsetimage (im, image, Memc[field]) + + switch (operation) { + case OP_EDIT: + call nh_editfield (im, image, Memc[field], + exprs, comment, verify, show, update) + case OP_RENAME: + call nh_renamefield (im, image, Memc[field], + exprs, verify, show, update) + case OP_DELETE: + call nh_deletefield (im, image, Memc[field], + exprs, verify, show, update) + } + nfields = nfields + 1 + } + + call imcfnl (flist) + } + call sfree(sp) +end + + +# NH_EDITFIELD -- Edit the value of the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure nh_editfield (im, image, field, valexpr, comment, verify, + show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o, fcomm, ncomm + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + call salloc (fcomm, HRECLEN, TY_CHAR) + call salloc (ncomm, HRECLEN, TY_CHAR) + + call strcpy (comment, Memc[ncomm], HRECLEN) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + + call imgcom (im, field, Memc[fcomm]) + if (streq (Memc[newval], ".") && streq (comment, ".")) { + # Merely print the value of the field. + + if (Memc[fcomm] == EOS) { + call printf ("%s,%s = %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + } else { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + call printf ("%s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[oldval]) + call pargstr(Memc[fcomm]) + } + + } else if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + if (streq (Memc[newval], ".")) { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + } + if (streq (comment, ".")) + call strcpy (Memc[fcomm], Memc[ncomm], SZ_LINE) + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (Memc[oldval], Memc[fcomm]) + call nh_pargstrc (Memc[defval], Memc[ncomm]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES && update == YES) + call nh_updatefield (im, image, field, Memc[oldval], + Memc[newval], Memc[fcomm], Memc[ncomm], show) + + call flush (STDOUT) + } + + } else { + if (streq (Memc[newval], ".")) { + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + } + if (streq (comment, ".")) + call strcpy (Memc[fcomm], Memc[ncomm], SZ_LINE) + if (update == YES) { + call nh_updatefield (im, image, field, Memc[oldval], + Memc[newval], Memc[fcomm], Memc[ncomm], show) + } + } + if (update == NO && show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (Memc[oldval], Memc[fcomm]) + call nh_pargstrc (Memc[newval], Memc[ncomm]) + } + + call sfree (sp) +end + + +# NH_RENAMEFIELD -- Rename the named field of the indicated image. +# The value expression is evaluated, interactively inspected if desired, +# and the resulting value put to the image. + +procedure nh_renamefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +int goahead, nl +pointer sp, ip, oldval, newval, defval, o + +bool streq() +pointer evexpr() +extern he_getop() +int getline(), imaccf(), strldxs(), locpr() +errchk evexpr, getline, imaccf, he_gval + +begin + call smark (sp) + call salloc (oldval, SZ_LINE, TY_CHAR) + call salloc (newval, SZ_LINE, TY_CHAR) + call salloc (defval, SZ_LINE, TY_CHAR) + + # Verify that the named field exists before going any further. + if (field[1] != '$') + if (imaccf (im, field) == NO) { + call eprintf ("parameter %s,%s not found\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # Get the old value. + call he_gval (im, image, field, Memc[oldval], SZ_LINE) + + # Evaluate the expression. Encode the result operand as a string. + # If the expression is not parenthesized, assume that is is already + # a string literal. + + if (valexpr[1] == '(') { + o = evexpr (valexpr, locpr (he_getop), 0) + call he_encodeop (o, Memc[newval], SZ_LINE) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } else + call strcpy (valexpr, Memc[newval], SZ_LINE) + call strupr (Memc[newval]) + + if (verify == YES) { + # Query for new value and edit the field. If the response is a + # blank line, use the default new value. If the response is "$" + # or EOF, do not change the value of the parameter. + + call strcpy (field, Memc[oldval], SZ_LINE) + if (streq (Memc[newval], ".")) + call strcpy (Memc[oldval], Memc[newval], SZ_LINE) + call strcpy (Memc[newval], Memc[defval], SZ_LINE) + call eprintf ("%s,%s (%s -> %s): ") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (Memc[newval]) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Do not skip leading whitespace; may be significant in a + # string literal. + + ip = newval + + # Do strip trailing newline since it is an artifact of getline. + nl = strldxs ("\n", Memc[ip]) + if (nl > 0) + Memc[ip+nl-1] = EOS + + # Decode user response. + if (Memc[ip] == '\\') { + ip = ip + 1 + goahead = YES + } else if (streq(Memc[ip],"n") || streq(Memc[ip],"no")) { + goahead = NO + } else if (streq(Memc[ip],"y") || streq(Memc[ip],"yes") || + Memc[ip] == EOS) { + call strcpy (Memc[defval], Memc[newval], SZ_LINE) + goahead = YES + } else { + if (ip > newval) + call strcpy (Memc[ip], Memc[newval], SZ_LINE) + goahead = YES + } + + # Edit field if so indicated. + if (goahead == YES && update == YES) + call nh_updatekey (im, image, field, Memc[newval], show) + + call flush (STDOUT) + } + + } else { + call strcpy (field, Memc[oldval], SZ_LINE) + if (update == YES) + call nh_updatekey (im, image, field, Memc[newval], show) + } + if (update == NO && show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (Memc[newval]) + } + + call sfree (sp) +end + + +# NH_INITFIELD -- Add a new field to the indicated image. If the field already +# existsdo not set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure nh_initfield (im, image, field, valexpr, comment, pkey, baf, + verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +char pkey[ARB] # +int baf +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imakbc, imastrc, imakic, imakrc + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + + if (imaccf (im, field) == YES) { + call eprintf ("parameter %s,%s already exists\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, strlen(valexpr), TY_CHAR) + call strcpy (valexpr, O_VALC(o), ARB) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + + if (update == YES) { + switch (O_TYPE(o)) { + case TY_BOOL: + if (pkey[1] != EOS && baf != 0) + call imakbci (im, field, O_VALB(o), comment, pkey, baf) + else + call imakbc (im, field, O_VALB(o), comment) + case TY_CHAR: + if (pkey[1] != EOS && baf != 0) + call imastrci (im, field, O_VALC(o), comment, pkey, baf) + else + call imastrc (im, field, O_VALC(o), comment) + case TY_INT: + if (pkey[1] != EOS && baf != 0) + call imakici (im, field, O_VALI(o), comment, pkey, baf) + else + call imakic (im, field, O_VALI(o), comment) + case TY_REAL: + if (pkey[1] != EOS && baf != 0) + call imakrci (im, field, O_VALR(o), comment, pkey, baf) + else + call imakrc (im, field, O_VALR(o), comment) + default: + call error (1, "unknown expression datatype") + } + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + call pargstr(comment) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# NH_ADDFIELD -- Add a new field to the indicated image. If the field already +# exists, merely set its value. The value expression is evaluated and the +# resulting value used as the initial value in adding the field to the image. + +procedure nh_addfield (im, image, field, valexpr, comment, pkey, baf, + verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # value expression +char comment[ARB] # keyword comment +char pkey[ARB] # pivot keyword name +int baf # either BEFORE or AFTER value +int verify # verify new value interactively +int show # print record of edit +int update # enable updating of the image + +bool numeric +int numlen, ip +pointer sp, newval, o +pointer evexpr() +bool streq() +int imaccf(), locpr(), strlen(), lexnum() +extern he_getop() +errchk imaccf, evexpr, imakbc, imastrc, imakic, imakrc + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + # If the named field already exists, this is really an edit operation + # rather than an add. Call editfield so that the usual verification + # can take place. + if (!streq(field, "comment") && !streq(field, "history")) { + if (imaccf (im, field) == YES) { + call nh_editfield (im, image, field, valexpr, comment, + verify, show, update) + call sfree (sp) + return + } + } + + # If the expression is not parenthesized, assume that is is already + # a string literal. If the expression is a string check for a simple + # numeric field. + + ip = 1 + numeric = (lexnum (valexpr, ip, numlen) != LEX_NONNUM) + if (numeric) + numeric = (numlen == strlen (valexpr)) + + if (numeric || valexpr[1] == '(') + o = evexpr (valexpr, locpr(he_getop), 0) + else { + call malloc (o, LEN_OPERAND, TY_STRUCT) + call xev_initop (o, max(1,strlen(valexpr)), TY_CHAR) + call strcpy (valexpr, O_VALC(o), SZ_LINE) + } + + # Add the field to the image (or update the value). The datatype of + # the expression value operand determines the datatype of the new + # parameter. + if (update == YES) { + switch (O_TYPE(o)) { + case TY_BOOL: + if (pkey[1] != EOS && baf != 0) + call imakbci (im, field, O_VALB(o), comment, pkey, baf) + else + call imakbc (im, field, O_VALB(o), comment) + case TY_CHAR: + if (streq(field, "comment") || + streq(field, "history") || + streq(field, "add_textf") || + streq(field, "add_blank")) { + if (streq(field, "add_textf")) { + call imputextf (im, O_VALC(o), pkey, baf) + } else { + call imphis (im, field, O_VALC(o), pkey, baf) + } + } else if (pkey[1] != EOS && baf != 0) { + call imastrci (im, field, O_VALC(o), comment, pkey, baf) + } else { + call imastrc (im, field, O_VALC(o), comment) + } + case TY_INT: + if (pkey[1] != EOS && baf != 0) + call imakici (im, field, O_VALI(o), comment, pkey, baf) + else + call imakic (im, field, O_VALI(o), comment) + case TY_REAL: + if (pkey[1] != EOS && baf != 0) + call imakrci (im, field, O_VALR(o), comment, pkey, baf) + else + call imakrc (im, field, O_VALR(o), comment) + default: + call error (1, "unknown expression datatype") + } + } + + if (show == YES) { + call he_encodeop (o, Memc[newval], SZ_LINE) + call printf ("add %s,%s = %s / %s\n") + call pargstr (image) + call pargstr (field) + call he_pargstr (Memc[newval]) + call pargstr(comment) + } + + call xev_freeop (o) + call mfree (o, TY_STRUCT) + call sfree (sp) +end + + +# NH_DELETEFIELD -- Delete a field from the indicated image. If the field does +# not exist, print a warning message. + +procedure nh_deletefield (im, image, field, valexpr, verify, show, update) + +pointer im # image descriptor of image to be edited +char image[ARB] # name of image to be edited +char field[ARB] # name of field to be edited +char valexpr[ARB] # not used +int verify # verify deletion interactively +int show # print record of edit +int update # enable updating of the image + +pointer sp, ip, newval +int getline(), imaccf() + +begin + call smark (sp) + call salloc (newval, SZ_LINE, TY_CHAR) + + if (imaccf (im, field) == NO) { + call eprintf ("nonexistent field %s,%s\n") + call pargstr (image) + call pargstr (field) + call sfree (sp) + return + } + + if (verify == YES) { + # Delete pending verification. + + call eprintf ("delete %s,%s ? (yes): ") + call pargstr (image) + call pargstr (field) + call flush (STDERR) + + if (getline (STDIN, Memc[newval]) != EOF) { + # Strip leading whitespace and trailing newline. + for (ip=newval; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == 'y') { + call imdelf (im, field) + if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } + } + } + + } else { + # Delete without verification. + + if (update == YES) { + iferr (call imdelf (im, field)) + call erract (EA_WARN) + else if (show == YES) { + call printf ("%s,%s deleted\n") + call pargstr (image) + call pargstr (field) + } else if (show == YES) + call printf ("%s,%s deleted, no update\n") + call pargstr (image) + call pargstr (field) + } + } + + call sfree (sp) +end + + +# NH_UPDATEFIELD -- Update the value of an image header field. + +procedure nh_updatefield (im, image, field, oldval, newval, oldcomm, + newcomm, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char oldval[ARB] # old value, encoded as a string +char newval[ARB] # new value, encoded as a string +char oldcomm[ARB] # old keyword comment +char newcomm[ARB] # new keyword comment +int show # print record of update + +begin + iferr (call impstrc (im, field, newval, newcomm)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call nh_pargstrc (oldval, oldcomm) + call nh_pargstrc (newval, newcomm) + + } +end + + +# NH_UPDATEKEY -- Update the image header field. + +procedure nh_updatekey (im, image, field, newkey, show) + +pointer im # image descriptor +char image[ARB] # image name +char field[ARB] # field name +char newkey[ARB] # new key +int show # print record of update + +begin + iferr (call imrenf (im, field, newkey)) { + call eprintf ("cannot update %s,%s\n") + call pargstr (image) + call pargstr (field) + return + } + if (show == YES) { + call printf ("%s,%s: %s -> %s\n") + call pargstr (image) + call pargstr (field) + call pargstr (field) + call pargstr (newkey) + + } +end + + +# NH_CPSTR -- Copy a string to a header record with optional comment. + +procedure nh_cpstr (str, outbuf) + +char str[ARB] # string to be printed +char outbuf[ARB] # comment string to be printed + +int ip +bool quoteit +pointer sp, op, buf + +begin + + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + op = buf + Memc[op] = '"' + op = op + 1 + + # Copy string to scratch buffer, enclosed in quotes. Check for + # embedded whitespace. + + quoteit = false + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_WHITE(str[ip])) { # detect whitespace + quoteit = true + Memc[op] = str[ip] + } else if (str[ip] == '\n') { # prettyprint newlines + Memc[op] = '\\' + op = op + 1 + Memc[op] = 'n' + } else # normal characters + Memc[op] = str[ip] + + if (ip < SZ_LINE) + op = op + 1 + } + + # If whitespace was seen pass the quoted string, otherwise pass the + # original input string. + + if (quoteit) { + Memc[op] = '"' + op = op + 1 + Memc[op] = EOS + call strcpy (Memc[buf], outbuf, SZ_LINE) + } else + call strcpy (str, outbuf, SZ_LINE) + + call sfree (sp) +end + + +# NH_PARGSTRC -- Pass a string to a printf statement plus the comment string. + procedure nh_pargstrc (str, comment) + +char str[ARB] # string to be printed +char comment[ARB] # comment string to be printed + +pointer sp, buf + +begin + + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call nh_cpstr (str, Memc[buf]) + + if (comment[1] != EOS) { + call strcat (" / ", Memc[buf], SZ_LINE) + call strcat (comment, Memc[buf], SZ_LINE) + } + + call pargstr (Memc[buf]) + + call sfree (sp) +end + + +# HE_GETPARS -- get the cl parameters for this task + +procedure he_getpars (operation, fields, valexpr, comment, + pivot, baf, update, verify, show) + +int operation +pointer fields # template listing fields to be processed +pointer valexpr # the value expression (if op=edit|add) +char comment[ARB] +char pivot[ARB] +int baf +int update +int verify +int show +bool clgetb(), streq() + +pointer ip +int btoi() + +begin + # Set switches. + operation = OP_EDIT + if (clgetb ("add")) + operation = OP_ADD + else if (clgetb ("addonly")) + operation = OP_INIT + else if (clgetb ("delete")) + operation = OP_DELETE + else if (clgetb ("rename")) + operation = OP_RENAME + + # If fields is NULL then this will be done in a command file. + if (fields != NULL) { + + # Get list of fields to be edited, added, or deleted. + call clgstr ("fields", Memc[fields], SZ_LINE) + for (ip=fields; IS_WHITE (Memc[ip]); ip=ip+1) + ; + call strcpy (Memc[ip], Memc[fields], SZ_LINE) + + # Set value expression. + Memc[valexpr] = EOS + if (operation != OP_DELETE) { + call clgstr ("value", Memc[valexpr], SZ_LINE) + if (operation != OP_RENAME) + call clgstr ("comment", comment, SZ_LINE) + + # Justify value + for (ip=valexpr; IS_WHITE (Memc[ip]); ip=ip+1) + ; + call strcpy (Memc[ip], Memc[valexpr], SZ_LINE) + ip = valexpr + while (Memc[ip] != EOS) + ip = ip + 1 + while (ip > valexpr && IS_WHITE (Memc[ip-1])) + ip = ip - 1 + Memc[ip] = EOS + } + + # If only printing results ignore the RENAME flag. + if (operation == OP_RENAME && streq (Memc[valexpr], ".")) { + operation = OP_EDIT + call strcpy (".", comment, SZ_LINE) + } + + } else { + Memc[valexpr] = EOS + comment[1] = EOS + } + + + # Get switches. If the expression value is ".", meaning print value + # rather than edit, then we do not use the switches. + + if (operation == OP_EDIT && streq (Memc[valexpr], ".") && + streq (comment, ".")) { + update = NO + verify = NO + show = NO + } else { + update = btoi (clgetb ("update")) + verify = btoi (clgetb ("verify")) + show = btoi (clgetb ("show")) + call clgstr ("after", pivot, SZ_LINE) + if (pivot[1] != EOS) + baf = AFTER + if (pivot[1] == EOS) { + call clgstr ("before", pivot, SZ_LINE) + if (pivot[1] != EOS) + baf = BEFORE + } + } +end + + +# NH_SETPAR -- Set a parameter. + +procedure nh_setpar (operation, dp_oper, dp_update, dp_verify, dp_show, + update, verify, show) +int operation +int dp_oper +int dp_update +int dp_verify +int dp_show +int update +int verify +int show + +begin + # If the value is positive then the parameter has been set + # in the command line. + + if (operation == OP_DEFPAR) + operation = dp_oper + if (update == -1) + update = dp_update + if (verify == -1) + verify = dp_verify + if (show == -1) + show = dp_show +end diff --git a/pkg/images/imutil/src/t_chpix.x b/pkg/images/imutil/src/t_chpix.x new file mode 100644 index 00000000..13c35cc3 --- /dev/null +++ b/pkg/images/imutil/src/t_chpix.x @@ -0,0 +1,238 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# T_CHPIXTYPE -- Change the pixel type of a list of images from the specified +# old pixel type to the new pixel type. The input images to be converted can +# be slected by pixel type. Conversion from one pixel type to another is +# direct and may involve loss of precision and dynamic range. Mapping of +# floating point numbers to integer numbers is done by truncation. + + +define CHP_ALL 1 # All types +define CHP_USHORT 2 # Unsigned short integer +define CHP_SHORT 3 # Short integers +define CHP_INT 4 # Integers +define CHP_LONG 5 # Long integers +define CHP_REAL 6 # Reals +define CHP_DOUBLE 7 # Doubles +define CHP_COMPLEX 8 # Complex + +define CHP_TYSTR "|all|ushort|short|int|long|real|double|complex|" + +procedure t_chpixtype() + +pointer imtlist1 # Input image list +pointer imtlist2 # Output image list + +pointer image1 # Input image +pointer image2 # Output image +pointer imtemp # Temporary file + +int list1, list2, intype, outtype, verbose +pointer im1, im2, sp, instr, outstr, imstr +bool clgetb() +int imtopen(), imtgetim(), imtlen(), clgwrd(), chp_gettype(), btoi() +pointer immap() + +errchk xt_mkimtemp, immap, imunmap, xt_delimtemp, chp_pixtype + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate temporary space. + call smark (sp) + call salloc (imtlist1, SZ_FNAME, TY_CHAR) + call salloc (imtlist2, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (instr, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call salloc (imstr, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + + # Get the input and output pixel types. + intype = clgwrd ("oldpixtype", Memc[instr], SZ_LINE, CHP_TYSTR) + outtype = clgwrd ("newpixtype", Memc[outstr], SZ_LINE, CHP_TYSTR) + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Loop over the set of input and output images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) { + + iferr { + + # Open the input and output images. + call xt_mkimtemp (Memc[image1], Memc[image2], Memc[imtemp], + SZ_FNAME) + im1 = immap (Memc[image1], READ_ONLY, 0) + if (intype == CHP_ALL || IM_PIXTYPE(im1) == chp_gettype(intype)) + im2 = immap (Memc[image2], NEW_COPY, im1) + else + im2 = NULL + + # Change the pixel type. + call chp_enctype (IM_PIXTYPE(im1), Memc[imstr], SZ_LINE) + if (im2 == NULL) { + if (verbose == YES) { + call printf ("Cannot change Image: %s (%s) -> ") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call printf ("Image: %s (%s)\n") + call pargstr (Memc[imtemp]) + call pargstr (Memc[outstr]) + } + } else { + if (verbose == YES) { + call printf ("Image: %s (%s) -> Image: %s (%s)\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call pargstr (Memc[imtemp]) + call pargstr (Memc[outstr]) + } + call chp_pixtype (im1, im2, chp_gettype (outtype)) + } + + # Close up the input and output images. + call imunmap (im1) + if (im2 != NULL) { + call imunmap (im2) + call xt_delimtemp (Memc[image2], Memc[imtemp]) + } + + } then { + call eprintf ("Error converting %s (%s) -> (%s)\n") + call pargstr (Memc[image1]) + call pargstr (Memc[imstr]) + call pargstr (Memc[outstr]) + call erract (EA_WARN) + } + } + + call imtclose (list1) + call imtclose (list2) + + call sfree (sp) +end + + +# CHP_PIXTYPE -- Change pixel types using line sequential image i/o. + +procedure chp_pixtype (im1, im2, outtype) + +pointer im1 # pointer to the input image +pointer im2 # pointer to the output image +int outtype # output pixel type + +int ncols +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer buf1, buf2 +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() + +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + ncols = IM_LEN(im1, 1) + + IM_PIXTYPE(im2) = outtype + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + switch (outtype) { + case TY_USHORT: + while (impnll(im2,buf2,v2) != EOF && imgnll(im1,buf1,v1) != EOF) + call amovl (Meml[buf1], Meml[buf2], ncols) + case TY_SHORT: + while (impnls(im2,buf2,v2) != EOF && imgnls(im1,buf1,v1) != EOF) + call amovs (Mems[buf1], Mems[buf2], ncols) + case TY_INT: + while (impnli(im2,buf2,v2) != EOF && imgnli(im1,buf1,v1) != EOF) + call amovi (Memi[buf1], Memi[buf2], ncols) + case TY_LONG: + while (impnll(im2,buf2,v2) != EOF && imgnll(im1,buf1,v1) != EOF) + call amovl (Meml[buf1], Meml[buf2], ncols) + case TY_REAL: + while (impnlr(im2,buf2,v2) != EOF && imgnlr(im1,buf1,v1) != EOF) + call amovr (Memr[buf1], Memr[buf2], ncols) + case TY_DOUBLE: + while (impnld(im2,buf2,v2) != EOF && imgnld(im1,buf1,v1) != EOF) + call amovd (Memd[buf1], Memd[buf2], ncols) + case TY_COMPLEX: + while (impnlx(im2,buf2,v2) != EOF && imgnlx(im1,buf1,v1) != EOF) + call amovx (Memx[buf1], Memx[buf2], ncols) + } + + call imflush (im2) +end + + +# CHP_GETTYPE -- Get the the image pixel type. + +int procedure chp_gettype (intype) + +int intype # input pixel type + +begin + switch (intype) { + case CHP_USHORT: + return (TY_USHORT) + case CHP_SHORT: + return (TY_SHORT) + case CHP_INT: + return (TY_INT) + case CHP_LONG: + return (TY_LONG) + case CHP_REAL: + return (TY_REAL) + case CHP_DOUBLE: + return (TY_DOUBLE) + case CHP_COMPLEX: + return (TY_COMPLEX) + default: + return (ERR) + } +end + + +# CHP_ENCTYPE -- Encode the pixel type string. + +procedure chp_enctype (pixtype, str, maxch) + +int pixtype # pixel type +char str[ARB] # string for encoding pixel type +int maxch # maximum characters + +begin + switch (pixtype) { + case TY_USHORT: + call strcpy ("ushort", str, maxch) + case TY_SHORT: + call strcpy ("short", str, maxch) + case TY_INT: + call strcpy ("int", str, maxch) + case TY_LONG: + call strcpy ("long", str, maxch) + case TY_REAL: + call strcpy ("real", str, maxch) + case TY_DOUBLE: + call strcpy ("double", str, maxch) + case TY_COMPLEX: + call strcpy ("complex", str, maxch) + } +end diff --git a/pkg/images/imutil/src/t_imarith.x b/pkg/images/imutil/src/t_imarith.x new file mode 100644 index 00000000..6d5f6105 --- /dev/null +++ b/pkg/images/imutil/src/t_imarith.x @@ -0,0 +1,489 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define ADD 1 # Opcodes. +define SUB 2 +define MUL 3 +define DIV 4 +define MIN 5 +define MAX 6 + +# T_IMARITH -- Simple image arithmetic. +# +# For each pixel in each image compute: +# +# operand1 op operand2 = result +# +# Do the operations as efficiently as possible. Allow operand1 or operand2 +# to be a constant. Allow resultant image to have the same name as an +# operand image. Allow lists for the operands and the results. +# Allow one of the operands to have extra dimensions but require that the +# common dimensions are of the same length. + +procedure t_imarith () + +int list1 # Operand1 list +int list2 # Operand2 list +int list3 # Result list +int op # Operator +bool verbose # Verbose option +bool noact # Noact option +double c1 # Constant for operand1 +double c2 # Constant for operand2 +double divzero # Zero divide replacement +int pixtype # Output pixel datatype +int calctype # Datatype for calculations + +int i, j, pixtype1, pixtype2 +short sc1, sc2, sdz +int hlist +double dval1, dval2 +pointer im1, im2, im3 +pointer sp, operand1, operand2, result, imtemp +pointer opstr, dtstr, field, title, hparams + +int imtopenp(), imtgetim(), imtlen(), imofnlu(), imgnfn() +double clgetd(), imgetd() +bool clgetb(), streq() +int clgwrd() +int gctod(), lexnum() +pointer immap() +errchk immap, imgetd, imputd + +begin + # Allocate memory for strings. + call smark (sp) + call salloc (operand1, SZ_FNAME, TY_CHAR) + call salloc (operand2, SZ_FNAME, TY_CHAR) + call salloc (result, SZ_FNAME, TY_CHAR) + call salloc (imtemp, SZ_FNAME, TY_CHAR) + call salloc (opstr, SZ_FNAME, TY_CHAR) + call salloc (dtstr, SZ_FNAME, TY_CHAR) + call salloc (field, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_IMTITLE, TY_CHAR) + call salloc (hparams, SZ_LINE, TY_CHAR) + + # Get the operands and the operator. + list1 = imtopenp ("operand1") + op = clgwrd ("op", Memc[opstr], SZ_FNAME, ",+,-,*,/,min,max,") + list2 = imtopenp ("operand2") + list3 = imtopenp ("result") + + # Get the rest of the options. + call clgstr ("hparams", Memc[hparams], SZ_LINE) + verbose = clgetb ("verbose") + noact = clgetb ("noact") + if (op == DIV) + divzero = clgetd ("divzero") + + # Check the number of elements. + if (((imtlen (list1) != 1) && (imtlen (list1) != imtlen (list3))) || + ((imtlen (list2) != 1) && (imtlen (list2) != imtlen (list3)))) { + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call error (1, "Wrong number of elements in the operand lists") + } + + # Do each operation. + while (imtgetim (list3, Memc[result], SZ_FNAME) != EOF) { + if (imtgetim (list1, Memc[imtemp], SZ_FNAME) != EOF) + call strcpy (Memc[imtemp], Memc[operand1], SZ_FNAME) + if (imtgetim (list2, Memc[imtemp], SZ_FNAME) != EOF) + call strcpy (Memc[imtemp], Memc[operand2], SZ_FNAME) + + # Image sections in the output are not allowed. + call imgsection (Memc[result], Memc[field], SZ_FNAME) + if (Memc[field] != EOS) { + call eprintf ( + "imarith: image sections in the output are not allowed (%s)\n") + call pargstr (Memc[result]) + next + } + + # To allow purely numeric file names first test if the operand + # is a file. If it is not then attempt to interpret the operand + # as a numerical constant. Otherwise it is an error. + iferr { + im1 = immap (Memc[operand1], READ_ONLY, 0) + pixtype1 = IM_PIXTYPE(im1) + } then { + i = 1 + j = gctod (Memc[operand1], i, c1) + if ((Memc[operand1+i-1]!=EOS) && (Memc[operand1+i-1]!=' ')) { + call eprintf ("%s is not an image or a number\n") + call pargstr (Memc[operand1]) + next + } + + i = 1 + pixtype1 = lexnum (Memc[operand1], i, j) + switch (pixtype1) { + case LEX_REAL: + pixtype1 = TY_REAL + default: + pixtype1 = TY_SHORT + } + im1 = NULL + } + + iferr { + im2 = immap (Memc[operand2], READ_ONLY, 0) + pixtype2 = IM_PIXTYPE(im2) + } then { + i = 1 + j = gctod (Memc[operand2], i, c2) + if ((Memc[operand2+i-1]!=EOS) && (Memc[operand2+i-1]!=' ')) { + call eprintf ("%s is not an image or a number\n") + call pargstr (Memc[operand2]) + if (im1 != NULL) + call imunmap (im1) + next + } + + i = 1 + pixtype2 = lexnum (Memc[operand2], i, j) + switch (pixtype2) { + case LEX_REAL: + pixtype2 = TY_REAL + default: + pixtype2 = TY_SHORT + } + im2 = NULL + } + + # Determine the output pixel datatype and calculation datatype. + call ima_set (pixtype1, pixtype2, op, pixtype, calctype) + + # If verbose or noact print the operation. + if (verbose || noact) { + call printf ("IMARITH:\n Operation = %s\n") + call pargstr (Memc[opstr]) + call printf (" Operand1 = %s\n Operand2 = %s\n") + call pargstr (Memc[operand1]) + call pargstr (Memc[operand2]) + call printf (" Result = %s\n Result pixel type = %s\n") + call pargstr (Memc[result]) + call dtstring (pixtype, Memc[dtstr], SZ_FNAME) + call pargstr (Memc[dtstr]) + call printf (" Calculation type = %s\n") + call dtstring (calctype, Memc[dtstr], SZ_FNAME) + call pargstr (Memc[dtstr]) + if (op == DIV) { + call printf ( + " Replacement value for division by zero = %g\n") + call pargd (divzero) + } + } + + # Do the operation if the no act switch is not set. + if (!noact) { + # Check the two operands have the same dimension lengths + # over the same dimensions. + if ((im1 != NULL) && (im2 != NULL)) { + j = OK + do i = 1, min (IM_NDIM (im1), IM_NDIM (im2)) + if (IM_LEN (im1, i) != IM_LEN (im2, i)) + j = ERR + if (j == ERR) { + call imunmap (im1) + call imunmap (im2) + call eprintf ( + "Input images have different dimensions\n") + next + } + } + + # Create a temporary output image as a copy of one of the + # operand images (the one with the highest dimension). + # This allows the resultant image to have + # the same name as one of the operand images. + if ((im1 != NULL) && (im2 != NULL)) { + call xt_mkimtemp (Memc[operand1], Memc[result], + Memc[imtemp], SZ_FNAME) + if (streq (Memc[result], Memc[imtemp])) + call xt_mkimtemp (Memc[operand2], Memc[result], + Memc[imtemp], SZ_FNAME) + if (IM_NDIM(im1) >= IM_NDIM(im2)) + im3 = immap (Memc[result], NEW_COPY, im1) + else + im3 = immap (Memc[result], NEW_COPY, im2) + } else if (im1 != NULL) { + call xt_mkimtemp (Memc[operand1], Memc[result], + Memc[imtemp], SZ_FNAME) + im3 = immap (Memc[result], NEW_COPY, im1) + } else if (im2 != NULL) { + call xt_mkimtemp (Memc[operand2], Memc[result], + Memc[imtemp], SZ_FNAME) + im3 = immap (Memc[result], NEW_COPY, im2) + } else + call error (0, "No operand images") + + # Set the result image title and pixel datatype. + call clgstr ("title", Memc[title], SZ_IMTITLE) + if (Memc[title] != EOS) + call strcpy (Memc[title], IM_TITLE (im3), SZ_IMTITLE) + IM_PIXTYPE (im3) = pixtype + + # Call the appropriate procedure to do the arithmetic + # efficiently. + switch (calctype) { + case TY_SHORT: + sc1 = c1 + sc2 = c2 + switch (op) { + case ADD: + call ima_adds (im1, im2, im3, sc1, sc2) + case SUB: + call ima_subs (im1, im2, im3, sc1, sc2) + case MUL: + call ima_muls (im1, im2, im3, sc1, sc2) + case DIV: + sdz = divzero + call ima_divs (im1, im2, im3, sc1, sc2, sdz) + case MIN: + call ima_mins (im1, im2, im3, sc1, sc2) + case MAX: + call ima_maxs (im1, im2, im3, sc1, sc2) + } + case TY_INT: + switch (op) { + case ADD: + call ima_addi (im1, im2, im3, int (c1), int (c2)) + case SUB: + call ima_subi (im1, im2, im3, int (c1), int (c2)) + case MUL: + call ima_muli (im1, im2, im3, int (c1), int (c2)) + case DIV: + call ima_divi (im1, im2, im3, int (c1), int (c2), + int (divzero)) + case MIN: + call ima_mini (im1, im2, im3, int (c1), int (c2)) + case MAX: + call ima_maxi (im1, im2, im3, int (c1), int (c2)) + } + case TY_LONG: + switch (op) { + case ADD: + call ima_addl (im1, im2, im3, long (c1), long (c2)) + case SUB: + call ima_subl (im1, im2, im3, long (c1), long (c2)) + case MUL: + call ima_mull (im1, im2, im3, long (c1), long (c2)) + case DIV: + call ima_divl (im1, im2, im3, long (c1), long (c2), + long (divzero)) + case MIN: + call ima_minl (im1, im2, im3, long (c1), long (c2)) + case MAX: + call ima_maxl (im1, im2, im3, long (c1), long (c2)) + } + case TY_REAL: + switch (op) { + case ADD: + call ima_addr (im1, im2, im3, real (c1), real (c2)) + case SUB: + call ima_subr (im1, im2, im3, real (c1), real (c2)) + case MUL: + call ima_mulr (im1, im2, im3, real (c1), real (c2)) + case DIV: + call ima_divr (im1, im2, im3, real (c1), real (c2), + real (divzero)) + case MIN: + call ima_minr (im1, im2, im3, real (c1), real (c2)) + case MAX: + call ima_maxr (im1, im2, im3, real (c1), real (c2)) + } + case TY_DOUBLE: + switch (op) { + case ADD: + call ima_addd (im1, im2, im3, double(c1), double(c2)) + case SUB: + call ima_subd (im1, im2, im3, double(c1), double(c2)) + case MUL: + call ima_muld (im1, im2, im3, double(c1), double(c2)) + case DIV: + call ima_divd (im1, im2, im3, double(c1), double(c2), + double(divzero)) + case MIN: + call ima_mind (im1, im2, im3, double(c1), double(c2)) + case MAX: + call ima_maxd (im1, im2, im3, double(c1), double(c2)) + } + } + + # Do the header parameters. + iferr { + ifnoerr (dval1 = imgetd (im3, "CCDMEAN")) + call imdelf (im3, "CCDMEAN") + + hlist = imofnlu (im3, Memc[hparams]) + while (imgnfn (hlist, Memc[field], SZ_FNAME) != EOF) { + if (im1 != NULL) + dval1 = imgetd (im1, Memc[field]) + else + dval1 = c1 + if (im2 != NULL) + dval2 = imgetd (im2, Memc[field]) + else + dval2 = c2 + + switch (op) { + case ADD: + call imputd (im3, Memc[field], dval1 + dval2) + case SUB: + call imputd (im3, Memc[field], dval1 - dval2) + case MUL: + call imputd (im3, Memc[field], dval1 * dval2) + case DIV: + if (dval2 == 0.) { + call eprintf ( + "WARNING: Division by zero in header keyword (%s)\n") + call pargstr (Memc[field]) + } else + call imputd (im3, Memc[field], dval1 / dval2) + case MIN: + call imputd (im3, Memc[field], min (dval1, dval2)) + case MAX: + call imputd (im3, Memc[field], max (dval1, dval2)) + } + } + call imcfnl (hlist) + } then + call erract (EA_WARN) + } + + # Unmap images and release the temporary output image. + if (im1 != NULL) + call imunmap (im1) + if (im2 != NULL) + call imunmap (im2) + if (!noact) { + call imunmap (im3) + call xt_delimtemp (Memc[result], Memc[imtemp]) + } + } + + call imtclose (list1) + call imtclose (list2) + call imtclose (list3) + call sfree (sp) +end + + +# IMA_SET -- Determine the output image pixel type and the calculation +# datatype. The default pixel types are based on the highest arithmetic +# precendence of the input images or constants. Division requires +# a minimum of real. + +procedure ima_set (pixtype1, pixtype2, op, pixtype, calctype) + +int pixtype1 # Pixel datatype of operand 1 +int pixtype2 # Pixel datatype of operand 2 +int pixtype # Pixel datatype of resultant image +int op # Operation +int calctype # Pixel datatype for calculations + +char line[1] +int max_type + +begin + # Determine maximum precedence datatype. + switch (pixtype1) { + case TY_SHORT: + if (op == DIV) + max_type = TY_REAL + else if (pixtype2 == TY_USHORT) + max_type = TY_LONG + else + max_type = pixtype2 + case TY_USHORT: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT)) + max_type = TY_LONG + else + max_type = pixtype2 + case TY_INT: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT)) + max_type = pixtype1 + else + max_type = pixtype2 + case TY_LONG: + if (op == DIV) + max_type = TY_REAL + else if ((pixtype2 == TY_SHORT) || (pixtype2 == TY_USHORT) || + (pixtype2 == TY_INT)) + max_type = pixtype1 + else + max_type = pixtype2 + case TY_REAL: + if (pixtype2 == TY_DOUBLE) + max_type = pixtype2 + else + max_type = pixtype1 + case TY_DOUBLE: + max_type = pixtype1 + } + + # Set calculation datatype. + call clgstr ("calctype", line, 1) + switch (line[1]) { + case '1': + if (pixtype1 == TY_USHORT) + calctype = TY_LONG + else + calctype = pixtype1 + case '2': + if (pixtype2 == TY_USHORT) + calctype = TY_LONG + else + calctype = pixtype2 + case EOS: + calctype = max_type + case 's': + calctype = TY_SHORT + case 'u': + calctype = TY_LONG + case 'i': + calctype = TY_INT + case 'l': + calctype = TY_LONG + case 'r': + calctype = TY_REAL + case 'd': + calctype = TY_DOUBLE + default: + call error (6, "Unrecognized datatype") + } + + # Set output pixel datatype. + call clgstr ("pixtype", line, 1) + switch (line[1]) { + case '1': + pixtype = pixtype1 + case '2': + pixtype = pixtype2 + case EOS: + pixtype = calctype + case 's': + pixtype = TY_SHORT + case 'u': + pixtype = TY_USHORT + case 'i': + pixtype = TY_INT + case 'l': + pixtype = TY_LONG + case 'r': + pixtype = TY_REAL + case 'd': + pixtype = TY_DOUBLE + default: + call error (6, "Unrecognized dataype") + } +end diff --git a/pkg/images/imutil/src/t_imaxes.x b/pkg/images/imutil/src/t_imaxes.x new file mode 100644 index 00000000..86d32fbd --- /dev/null +++ b/pkg/images/imutil/src/t_imaxes.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +define SZ_PARAM 5 + + +# IMAXES -- Determine the number and lengths of the axes of an image. +# Called from CL scripts. This routine will go away when we get DBIO +# access from the CL. + +procedure t_imaxes() + +char imname[SZ_FNAME] +char param[SZ_PARAM] +int i +pointer im +pointer immap() + +begin + call clgstr ("image", imname, SZ_FNAME) + im = immap (imname, READ_ONLY, 0) + + call clputi ("ndim", IM_NDIM(im)) + + do i = 1, IM_MAXDIM { + call sprintf (param, SZ_PARAM, "len%d") + call pargi (i) + call clputl (param, IM_LEN(im,i)) + } + + call imunmap (im) +end diff --git a/pkg/images/imutil/src/t_imcopy.x b/pkg/images/imutil/src/t_imcopy.x new file mode 100644 index 00000000..b79f0d9d --- /dev/null +++ b/pkg/images/imutil/src/t_imcopy.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMCOPY -- Copy image(s) +# +# The input images are given by an image template list. The output +# is either a matching list of images or a directory. +# The number of input images may be either one or match the number of output +# images. Image sections are allowed in the input images and are ignored +# in the output images. If the input and output image names are the same +# then the copy is performed to a temporary file which then replaces the +# input image. + +procedure t_imcopy() + +char imtlist1[SZ_LINE] # Input image list +char imtlist2[SZ_LINE] # Output image list +bool verbose # Print operations? + +char image1[SZ_PATHNAME] # Input image name +char image2[SZ_PATHNAME] # Output image name +char dirname1[SZ_PATHNAME] # Directory name +char dirname2[SZ_PATHNAME] # Directory name + +int list1, list2, root_len + +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb() + +begin + # Get input and output image template lists. + + call clgstr ("input", imtlist1, SZ_LINE) + call clgstr ("output", imtlist2, SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (imtlist2, dirname2, SZ_PATHNAME) > 0) { + list1 = imtopen (imtlist1) + while (imtgetim (list1, image1, SZ_PATHNAME) != EOF) { + + # Strip the image section first because fnldir recognizes it + # as part of a directory. Place the input image name + # without a directory or image section in string dirname1. + + call get_root (image1, image2, SZ_PATHNAME) + root_len = fnldir (image2, dirname1, SZ_PATHNAME) + call strcpy (image2[root_len + 1], dirname1, SZ_PATHNAME) + + call strcpy (dirname2, image2, SZ_PATHNAME) + call strcat (dirname1, image2, SZ_PATHNAME) + call img_imcopy (image1, image2, verbose) + } + call imtclose (list1) + + } else { + # Expand the input and output image lists. + + list1 = imtopen (imtlist1) + list2 = imtopen (imtlist2) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same") + } + + # Do each set of input/output images. + + while ((imtgetim (list1, image1, SZ_PATHNAME) != EOF) && + (imtgetim (list2, image2, SZ_PATHNAME) != EOF)) { + + call img_imcopy (image1, image2, verbose) + } + + call imtclose (list1) + call imtclose (list2) + } +end diff --git a/pkg/images/imutil/src/t_imdivide.x b/pkg/images/imutil/src/t_imdivide.x new file mode 100644 index 00000000..510e49e5 --- /dev/null +++ b/pkg/images/imutil/src/t_imdivide.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# T_IMDIVIDE -- Image division with rescaling. + +# Options for rescaling. +define NORESC 1 # Do not scale resultant image +define MEAN 2 # Scale resultant mean to given value +define NUMER 3 # Scale resultant mean to mean of numerator + +procedure t_imdivide () + +char image1[SZ_FNAME] # Numerator image +char image2[SZ_FNAME] # Denominator image +char image3[SZ_FNAME] # Resultant image +char title[SZ_IMTITLE] # Resultant image title +int rescale # Option for rescaling +real constant # Replacement for zero divide +bool verbose # Verbose output? + +char str[SZ_LINE] +int i, npix, ntotal +real sum1, sum2, sum3, scale +long line1[IM_MAXDIM], line2[IM_MAXDIM], line3[IM_MAXDIM] +pointer im1, im2, im3, data1, data2, data3 + +int clgwrd(), imgnlr(), impnlr() +bool clgetb(), strne() +real clgetr(), asumr(), ima_efncr() +pointer immap() +extern ima_efncr + +common /imadcomr/ constant + +begin + # Access images and set parameters. + call clgstr ("numerator", image1, SZ_FNAME) + im1 = immap (image1, READ_ONLY, 0) + call clgstr ("denominator", image2, SZ_FNAME) + im2 = immap (image2, READ_ONLY, 0) + call clgstr ("resultant", image3, SZ_FNAME) + im3 = immap (image3, NEW_COPY, im1) + + if (IM_NDIM (im1) != IM_NDIM (im2)) + call error (0, "Input images have different dimensions") + do i = 1, IM_NDIM (im1) + if (IM_LEN (im1, i) != IM_LEN (im2, i)) + call error (0, "Input images have different sizes") + + call clgstr ("title", title, SZ_IMTITLE) + if (strne (title, "*")) + call strcpy (title, IM_TITLE(im3), SZ_IMTITLE) + IM_PIXTYPE(im3) = TY_REAL + + constant = clgetr ("constant") + verbose = clgetb ("verbose") + + # Initialize. + npix = IM_LEN(im1, 1) + ntotal = 0 + sum1 = 0. + sum2 = 0. + sum3 = 0. + call amovkl (long(1), line1, IM_MAXDIM) + call amovkl (long(1), line2, IM_MAXDIM) + call amovkl (long(1), line3, IM_MAXDIM) + + # Loop through the images doing the division. + # Accumulate the sums for mean values. + while (impnlr (im3, data3, line3) != EOF) { + i = imgnlr (im1, data1, line1) + i = imgnlr (im2, data2, line2) + call advzr (Memr[data1], Memr[data2], Memr[data3], npix, ima_efncr) + sum1 = sum1 + asumr (Memr[data1], npix) + sum2 = sum2 + asumr (Memr[data2], npix) + sum3 = sum3 + asumr (Memr[data3], npix) + ntotal = ntotal + npix + } + sum1 = sum1 / ntotal + sum2 = sum2 / ntotal + sum3 = sum3 / ntotal + + # Close the images. + call imunmap (im1) + call imunmap (im2) + call imunmap (im3) + + # Print image means if verbose. + if (verbose) { + call printf ("Task imdivide:\n") + call printf (" %s: Mean = %g\n") + call pargstr (image1) + call pargr (sum1) + call printf (" %s: Mean = %g\n") + call pargstr (image2) + call pargr (sum2) + call printf (" %s: Mean = %g\n") + call pargstr (image3) + call pargr (sum3) + } + + # Determine resultant image rescaling. + rescale = clgwrd ("rescale", str, SZ_LINE, ",norescale,mean,numerator,") + switch (rescale) { + case NORESC: + return + case MEAN: + scale = clgetr ("mean") / sum3 + case NUMER: + scale = sum1 / sum3 + } + + if(verbose) { + call printf (" %s: Scale = %g\n") + call pargstr (image3) + call pargr (scale) + } + + # Open image read_write and initialize line counters. + im1 = immap (image3, READ_WRITE, 0) + call amovkl (long(1), line1, IM_MAXDIM) + call amovkl (long(1), line2, IM_MAXDIM) + + # Loop through the image rescaling the image lines. + while (imgnlr (im1, data1, line1) != EOF) { + i = impnlr (im1, data2, line2) + call amulkr (Memr[data1], scale, Memr[data2], npix) + } + + call imunmap (im1) +end diff --git a/pkg/images/imutil/src/t_imjoin.x b/pkg/images/imutil/src/t_imjoin.x new file mode 100644 index 00000000..810c0a2d --- /dev/null +++ b/pkg/images/imutil/src/t_imjoin.x @@ -0,0 +1,272 @@ +include +include +include + +define DEFBUFSIZE 65536 # default IMIO buffer size +define FUDGE 0.8 # fudge factor + + +# T_IMJOIN -- Produce a single output image from a list of input images +# by joining the images in the input image list along a single dimension. +# The set of input images need have the same number of dimensions and +# elements per dimension ONLY along the axes not being joined. +# The output pixel type will be converted to the highest precedence pixel +# type if not all the images do not have the same pixel type. + +procedure t_imjoin() + +int i, j, joindim, list, nimages, inpixtype, ndim, nelems[IM_MAXDIM] +int bufsize, maxsize, memory, oldsize, outpixtype, verbose +pointer sp, in, out, im, im1, input, output + +bool clgetb() +#char clgetc() +int imtopenp(), imtlen(), imtgetim(), clgeti(), btoi() +int getdatatype(), ij_tymax(), sizeof(), begmem(), errcode() +pointer immap() +errchk immap + +define retry_ 99 + +begin + # Allocate working space. + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + + # Get the parameters. Note that clgetc no longer accepts a blank + # string as input so clgstr is used to fetch the pixtype parameter + # and input is used as the temporary holding variable. + list = imtopenp ("input") + call clgstr ("output", Memc[output], SZ_FNAME) + joindim = clgeti ("join_dimension") + #outpixtype = getdatatype (clgetc ("pixtype")) + call clgstr ("pixtype", Memc[input], SZ_FNAME) + outpixtype = getdatatype (Memc[input]) + verbose = btoi (clgetb ("verbose")) + + # Check to make sure that the input image list is not empty. + nimages = imtlen (list) + if (nimages == 0) { + call imtclose (list) + call sfree (sp) + call error (0, "The input image list is empty") + } else + call salloc (in, nimages, TY_POINTER) + + # Check the the join dimension is not too large. + if (joindim > IM_MAXDIM) + call error (0, + "The join dimension cannot be greater then the current IM_MAXDIM") + + bufsize = 0 + +retry_ + + # Map the input images. + nimages = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + nimages = nimages + 1 + Memi[in+nimages-1] = immap (Memc[input], READ_ONLY, 0) + } + + # Determine the dimensionality, size, and pixel type of the output + # image. Force the output image to have the same number of dimensions + # as the input images, with the following check even though the + # remainder of the code permits stacking the images into a higher + # dimension. + + im = Memi[in] + inpixtype = IM_PIXTYPE(im) + if (joindim > IM_NDIM(im)) { + call eprintf ( + "ERROR: For image %s ndim is %d max join dimension is %d\n") + call pargstr (IM_HDRFILE(im)) + call pargi (IM_NDIM(im)) + call pargi (IM_NDIM(im)) + call error (0, "The user-specified join dimension is too large") + } + ndim = max (IM_NDIM(im), joindim) + do j = 1, ndim { + if (j <= IM_NDIM(im)) + nelems[j] = IM_LEN(im,j) + else + nelems[j] = 1 + } + + # Make sure that all the input images have the same dimensionality, + # and that the length of each dimension is the same for all dimensions + # but the one being joined. + + do i = 2, nimages { + im1 = Memi[in+i-1] + if (IM_NDIM(im1) != IM_NDIM(im)) + call error (0, "The input images have different dimensions") + ndim = max (ndim, IM_NDIM(im1)) + do j = 1, ndim { + if (j > IM_NDIM(im1)) + nelems[j] = nelems[j] + 1 + else if (j == joindim) + nelems[j] = nelems[j] + IM_LEN(im1,j) + else if (IM_LEN(im1,j) != nelems[j]) + call error (0, + "The input images have unequal sizes in the non-join dimension") + } + inpixtype = ij_tymax (inpixtype, IM_PIXTYPE(im1)) + } + + # Open the output image and set its pixel data type, number of + # dimensions, and length of each of the dimensions. + + out = immap (Memc[output], NEW_COPY, Memi[in]) + if (outpixtype == ERR || outpixtype == TY_BOOL) + IM_PIXTYPE(out) = inpixtype + else + IM_PIXTYPE(out) = outpixtype + IM_NDIM(out) = ndim + do j = 1, ndim + IM_LEN(out,j) = nelems[j] + + if (bufsize == 0) { + + # Set initial IMIO buffer size based on the number of images + # and maximum amount of working memory available. The buffer + # size may be adjusted later if the task runs out of memory. + # The FUDGE factor is used to allow for the size of the + # program, memory allocator inefficiencies, and any other + # memory requirements besides IMIO. + + bufsize = 1 + do i = 1, IM_NDIM(out) + bufsize = bufsize * IM_LEN(out,i) + bufsize = bufsize * sizeof (inpixtype) + bufsize = min (bufsize, DEFBUFSIZE) + memory = begmem ((nimages + 1) * bufsize, oldsize, maxsize) + memory = min (memory, int (FUDGE * maxsize)) + bufsize = memory / (nimages + 1) + } + + # Join the images along the join dimension. If an out of memory error + # occurs close all images and files, divide the IMIO buffer size in + # half and try again. + + iferr { + switch (inpixtype) { + case TY_SHORT: + call imjoins (Memi[in], nimages, out, joindim, outpixtype) + case TY_INT: + call imjoini (Memi[in], nimages, out, joindim, outpixtype) + case TY_USHORT, TY_LONG: + call imjoinl (Memi[in], nimages, out, joindim, outpixtype) + case TY_REAL: + call imjoinr (Memi[in], nimages, out, joindim, outpixtype) + case TY_DOUBLE: + call imjoind (Memi[in], nimages, out, joindim, outpixtype) + case TY_COMPLEX: + call imjoinx (Memi[in], nimages, out, joindim, outpixtype) + } + } then { + switch (errcode()) { + case SYS_MFULL: + do j = 1, nimages + call imunmap (Memi[in+j-1]) + call imunmap (out) + call imdelete (Memc[output]) + call imtrew (list) + bufsize = bufsize / 2 + goto retry_ + default: + call erract (EA_ERROR) + } + } + + if (verbose == YES) + call ij_verbose (Memi[in], nimages, out, joindim) + + # Unmap all the images. + call imunmap (out) + do i = 1, nimages + call imunmap (Memi[in+i-1]) + + # Restore memory. + call sfree (sp) + call fixmem (oldsize) +end + + +define MAX_NTYPES 8 +define MAX_NPIXTYPES 7 + +# IJ_TYMAX -- Return the data type of highest precedence. + +int procedure ij_tymax (type1, type2) + +int type1, type2 # Input data types + +int i, j, order[MAX_NTYPES] +data order/TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE,TY_COMPLEX, + TY_REAL/ +begin + for (i=1; (i<=MAX_NPIXTYPES) && (type1!=order[i]); i=i+1) + ; + for (j=1; (j<=MAX_NPIXTYPES) && (type2!=order[j]); j=j+1) + ; + return (order[max(i,j)]) +end + + +# IJ_VERBOSE -- Print messages about the actions taken by IMJOIN. + +procedure ij_verbose (imptrs, nimages, outptr, joindim) + +pointer imptrs[ARB] # array of input image pointers +int nimages # the number of input images +pointer outptr # the output image pointer +int joindim # the join dimension + +int i, j, nindim, noutdim +long offset + +begin + noutdim = IM_NDIM(outptr) + offset = 1 + + do i = 1, nimages { + + nindim = IM_NDIM(imptrs[i]) + call printf ("Join: %s size: ") + call pargstr (IM_HDRFILE(imptrs[i])) + do j = 1, nindim { + if (j == nindim) + call printf ("%d -> ") + else + call printf ("%d X ") + call pargl (IM_LEN(imptrs[i],j)) + } + + call printf ("%s[") + call pargstr (IM_HDRFILE(outptr)) + do j = 1, noutdim { + if (j > nindim) { + call printf ("%d:%d") + call pargi (i) + call pargi (i) + } else if (j == joindim) { + call printf ("%d:%d") + call pargl (offset) + call pargl (offset + IM_LEN(imptrs[i],j)-1) + offset = offset + IM_LEN(imptrs[i],j) + } else { + call printf ("1:%d") + call pargl (IM_LEN(outptr,j)) + } + if (j != noutdim) + call printf (",") + else + call printf ("]") + } + + call printf ("\n") + + } +end diff --git a/pkg/images/imutil/src/t_imrename.x b/pkg/images/imutil/src/t_imrename.x new file mode 100644 index 00000000..25562044 --- /dev/null +++ b/pkg/images/imutil/src/t_imrename.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMRENAME -- Rename an image or list of images, or move a image or images +# to a new directory. Pixel files are moved to the current IMDIR. Moving +# an image to the same directory will move the pixel file if IMDIR has been +# changed since the image was created. + +procedure t_imrename() + +pointer sp, old_list, new_list +pointer old_name, new_name, old_dir, new_dir +bool verbose + +int list1, list2, root_len +int imtopen(), imtgetim(), imtlen() +int fnldir(), isdirectory() +bool clgetb() + +begin + call smark (sp) + call salloc (old_list, SZ_LINE, TY_CHAR) + call salloc (new_list, SZ_LINE, TY_CHAR) + call salloc (old_name, SZ_PATHNAME, TY_CHAR) + call salloc (new_name, SZ_PATHNAME, TY_CHAR) + call salloc (new_dir, SZ_PATHNAME, TY_CHAR) + call salloc (old_dir, SZ_PATHNAME, TY_CHAR) + + # Get input and output image template lists. + call clgstr ("oldnames", Memc[old_list], SZ_LINE) + call clgstr ("newnames", Memc[new_list], SZ_LINE) + verbose = clgetb ("verbose") + + # Check if the output string is a directory. + + if (isdirectory (Memc[new_list], Memc[new_dir], SZ_PATHNAME) > 0) { + list1 = imtopen (Memc[old_list]) + while (imtgetim (list1, Memc[old_name], SZ_PATHNAME) != EOF) { + + # Strip the image section first because fnldir recognizes it + # as part of a directory. Place the input image name + # without a directory or image section in string Memc[old_dir]. + + call get_root (Memc[old_name], Memc[new_name], SZ_PATHNAME) + root_len = fnldir (Memc[new_name], Memc[old_dir], SZ_PATHNAME) + call strcpy (Memc[new_name+root_len], Memc[old_dir],SZ_PATHNAME) + + call strcpy (Memc[new_dir], Memc[new_name], SZ_PATHNAME) + call strcat (Memc[old_dir], Memc[new_name], SZ_PATHNAME) + call img_rename (Memc[old_name], Memc[new_name], verbose) + } + call imtclose (list1) + + } else { + # Expand the input and output image lists. + list1 = imtopen (Memc[old_list]) + list2 = imtopen (Memc[new_list]) + + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (1, "Different number of old and new image names") + } + + # Do each set of input/output images. + while ((imtgetim (list1, Memc[old_name], SZ_PATHNAME) != EOF) && + (imtgetim (list2, Memc[new_name], SZ_PATHNAME) != EOF)) { + + call img_rename (Memc[old_name], Memc[new_name], verbose) + } + + call imtclose (list1) + call imtclose (list2) + } + + call sfree (sp) +end + + +# IMG_RENAME -- Rename an image, optionally printing a message to the STDOUT. + +procedure img_rename (old_name, new_name, verbose) + +char old_name[ARB] #I old image name +char new_name[ARB] #I new image name +bool verbose #I print message? + +begin + iferr (call imrename (old_name, new_name)) { + call eprintf ("Warning: cannot rename `%s' -> `%s'\n") + call pargstr (old_name) + call pargstr (new_name) + } else if (verbose) { + call printf ("`%s' -> `%s'\n") + call pargstr (old_name) + call pargstr (new_name) + call flush (STDOUT) + } +end diff --git a/pkg/images/imutil/src/t_imreplace.x b/pkg/images/imutil/src/t_imreplace.x new file mode 100644 index 00000000..2b8750ac --- /dev/null +++ b/pkg/images/imutil/src/t_imreplace.x @@ -0,0 +1,83 @@ +include + +# T_IMREP -- Replace pixels in a window with a constant. + +procedure t_imrep () + +char imtlist[SZ_LINE] # Images to be editted +real lower # Lower limit of window +real upper # Upper limit of window +real value # Replacement value +real radius # Radius +real img # Imaginary part for complex + +int list +char image[SZ_FNAME] +pointer im + +int imtopen(), imtgetim() +real clgetr() +pointer immap() + +begin + # Get image template list. + + call clgstr ("images", imtlist, SZ_LINE) + list = imtopen (imtlist) + + # Get the parameters. + + value = clgetr ("value") + img = clgetr ("imaginary") + lower = clgetr ("lower") + upper = clgetr ("upper") + radius = max (0., clgetr ("radius")) + + # Replace the pixels in each image. Optimize IMIO. + + while (imtgetim (list, image, SZ_FNAME) != EOF) { + + im = immap (image, READ_WRITE, 0) + + if (radius < 1.) { + switch (IM_PIXTYPE (im)) { + case TY_SHORT: + call imreps (im, lower, upper, value, img) + case TY_INT: + call imrepi (im, lower, upper, value, img) + case TY_USHORT, TY_LONG: + call imrepl (im, lower, upper, value, img) + case TY_REAL: + call imrepr (im, lower, upper, value, img) + case TY_DOUBLE: + call imrepd (im, lower, upper, value, img) + case TY_COMPLEX: + call imrepx (im, lower, upper, value, img) + default: + call error (0, "Unsupported image pixel datatype") + } + + } else { + switch (IM_PIXTYPE (im)) { + case TY_SHORT: + call imrreps (im, lower, upper, radius, value, img) + case TY_INT: + call imrrepi (im, lower, upper, radius, value, img) + case TY_USHORT, TY_LONG: + call imrrepl (im, lower, upper, radius, value, img) + case TY_REAL: + call imrrepr (im, lower, upper, radius, value, img) + case TY_DOUBLE: + call imrrepd (im, lower, upper, radius, value, img) + case TY_COMPLEX: + call imrrepx (im, lower, upper, radius, value, img) + default: + call error (0, "Unsupported image pixel datatype") + } + } + + call imunmap (im) + } + + call imtclose (list) +end diff --git a/pkg/images/imutil/src/t_imslice.x b/pkg/images/imutil/src/t_imslice.x new file mode 100644 index 00000000..6942ec05 --- /dev/null +++ b/pkg/images/imutil/src/t_imslice.x @@ -0,0 +1,472 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# T_IMSLICE -- Slice an input image into a list of output images equal in +# length to the length of the dimension to be sliced. The remaining +# dimensions are unchanged. For a 1 dimensionsal image this task is a null +# operation. + +procedure t_imslice() + +pointer imtlist1 # Input image list +pointer imtlist2 # Output image list +pointer image1 # Input image +pointer image2 # Output image +int sdim # Dimension to be sliced +int verbose # Verbose mode + +pointer sp +int list1, list2 + +bool clgetb() +int imtopen(), imtgetim(), imtlen(), btoi(), clgeti() +errchk sl_slice + +begin + call smark (sp) + call salloc (imtlist1, SZ_FNAME, TY_CHAR) + call salloc (imtlist2, SZ_FNAME, TY_CHAR) + call salloc (image1, SZ_FNAME, TY_CHAR) + call salloc (image2, SZ_FNAME, TY_CHAR) + + # Get task parameters. + call clgstr ("input", Memc[imtlist1], SZ_FNAME) + call clgstr ("output", Memc[imtlist2], SZ_FNAME) + sdim = clgeti ("slice_dimension") + verbose = btoi (clgetb ("verbose")) + + list1 = imtopen (Memc[imtlist1]) + list2 = imtopen (Memc[imtlist2]) + if (imtlen (list1) != imtlen (list2)) { + call imtclose (list1) + call imtclose (list2) + call error (0, "Number of input and output images not the same.") + } + + # Loop over the set of input and output images + while ((imtgetim (list1, Memc[image1], SZ_FNAME) != EOF) && + (imtgetim (list2, Memc[image2], SZ_FNAME) != EOF)) + call sl_imslice (Memc[image1], Memc[image2], sdim, verbose) + + call imtclose (list1) + call imtclose (list2) + + call sfree (sp) +end + + +# SL_IMSLICE -- Procedure to slice an n-dimensional image into a set +# of images with one fewer dimensions. A number is appendend to the +# output image name indicating which element of the n-th dimension the +# new image originated from. + +procedure sl_imslice (image1, image2, sdim, verbose) + +char image1[ARB] # input image +char image2[ARB] # output image +int sdim # slice dimension +int verbose # verbose mode + +int i, j, ndim, fdim, ncols, nlout, nimout, pdim +int axno[IM_MAXDIM], axval[IM_MAXDIM] +pointer sp, inname, outname, outsect, im1, im2, buf1, buf2, vim1, vim2 +pointer mw, vs, ve +real shifts[IM_MAXDIM] + +pointer immap(), mw_openim() +int mw_stati() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int imggss(), imggsi(), imggsl(), imggsr(), imggsd(), imggsx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +bool envgetb() + +errchk imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +errchk imggss(), imggsi(), imggsl(), imggsr(), imggsd(), imggsx() +errchk impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() + +begin + iferr (im1 = immap (image1, READ_ONLY, 0)) { + call erract (EA_WARN) + return + } + + ndim = IM_NDIM(im1) + + # Check that sdim is in range. + if (sdim > ndim) { + call printf ("Image %s has fewer than %d dimensions.\n") + call pargstr (image1) + call pargi (sdim) + call imunmap (im1) + return + } + + # Cannot slice 1D images. + if (ndim == 1) { + call printf ("Image %s is 1 dimensional.\n") + call pargstr (image1) + call imunmap (im1) + return + } + + # Cannot slice an image which is degnerate in slice dimension. + #if (IM_LEN(im1,sdim) == 1) { + #call printf ("Image %s is degenerate in the %d dimension.\n") + #call pargstr (image1) + #call pargi (sdim) + #call imunmap (im1) + #return + #} + + call smark (sp) + call salloc (inname, SZ_LINE, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + call salloc (outsect, SZ_LINE, TY_CHAR) + + call salloc (vs, IM_MAXDIM, TY_LONG) + call salloc (ve, IM_MAXDIM, TY_LONG) + call salloc (vim1, IM_MAXDIM, TY_LONG) + call salloc (vim2, IM_MAXDIM, TY_LONG) + + # Compute the number of output images. and the number of columns + nimout = IM_LEN(im1, sdim) + + # Compute the number of lines and columns in the output image. + if (sdim == 1) { + fdim = 2 + ncols = IM_LEN(im1,2) + } else { + fdim = 1 + ncols = IM_LEN(im1,1) + } + nlout = 1 + do i = 1, sdim - 1 + nlout = nlout * IM_LEN(im1,i) + do i = sdim + 1, ndim + nlout = nlout * IM_LEN(im1,i) + nlout = nlout / ncols + + call amovkl (long(1), Meml[vim1], IM_MAXDIM) + do i = 1, nimout { + + # Construct the output image name. + call sprintf (Memc[outname], SZ_FNAME, "%s%03d") + call pargstr (image2) + call pargi (i) + + # Open the output image. + iferr (im2 = immap (Memc[outname], NEW_COPY, im1)) { + call erract (EA_WARN) + call imunmap (im1) + call sfree (sp) + return + } else { + IM_NDIM(im2) = ndim - 1 + do j = 1, sdim - 1 + IM_LEN(im2,j) = IM_LEN(im1,j) + do j = sdim + 1, IM_NDIM(im1) + IM_LEN(im2,j-1) = IM_LEN(im1,j) + } + + # Print messages on the screen. + if (verbose == YES) { + call sl_einsection (im1, i, sdim, Memc[inname], SZ_LINE) + call sl_esection (im2, Memc[outsect], SZ_LINE) + call printf ("Copied image %s %s -> %s %s\n") + call pargstr (image1) + call pargstr (Memc[inname]) + call pargstr (Memc[outname]) + call pargstr (Memc[outsect]) + call flush (STDOUT) + } + + # Initialize the v vectors for each new image. + if (sdim != ndim) { + do j = 1, ndim { + if (j == sdim) { + Meml[vs+j-1] = i + Meml[ve+j-1] = i + } else if (j == fdim) { + Meml[vs+j-1] = 1 + Meml[ve+j-1] = IM_LEN(im1,j) + } else { + Meml[vs+j-1] = 1 + Meml[ve+j-1] = 1 + } + } + } + + # Loop over the appropriate range of lines. + call amovkl (long(1), Meml[vim2], IM_MAXDIM) + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + if (sdim == ndim) { + do j = 1, nlout { + if (impnls (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnls (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovs (Mems[buf1], Mems[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnls (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggss (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovs (Mems[buf1], Mems[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_USHORT, TY_INT: + if (sdim == ndim) { + do j = 1, nlout { + if (impnli (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnli (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovi (Memi[buf1], Memi[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnli (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1= imggsi (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovi (Memi[buf1], Memi[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_LONG: + if (sdim == ndim) { + do j = 1, nlout { + if (impnll (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnll (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovl (Meml[buf1], Meml[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnll (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsl (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovl (Meml[buf1], Meml[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_REAL: + if (sdim == ndim) { + do j = 1, nlout { + if (impnlr (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnlr (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnlr (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsr (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovr (Memr[buf1], Memr[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), + fdim, sdim, ndim) + } + } + case TY_DOUBLE: + if (sdim == ndim) { + do j = 1, nlout { + if (impnld (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnld (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovd (Memd[buf1], Memd[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnld (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsd (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovd (Memd[buf1], Memd[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + case TY_COMPLEX: + if (sdim == ndim) { + do j = 1, nlout { + if (impnlx (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + if (imgnlx (im1, buf1, Meml[vim1]) == EOF) + call error (0, "Error reading input image.") + call amovx (Memx[buf1], Memx[buf2], ncols) + } + } else { + do j = 1, nlout { + if (impnlx (im2, buf2, Meml[vim2]) == EOF) + call error (0, "Error writing output image.") + buf1 = imggsx (im1, Meml[vs], Meml[ve], IM_NDIM(im1)) + if (buf1 == EOF) + call error (0, "Error reading input image.") + call amovx (Memx[buf1], Memx[buf2], ncols) + call sl_loop (Meml[vs], Meml[ve], IM_LEN(im1,1), fdim, + sdim, ndim) + } + } + } + + # Update the wcs. + if (! envgetb ("nowcs")) { + + # Open and shift the wcs. + mw = mw_openim (im1) + call aclrr (shifts, ndim) + shifts[sdim] = -(i - 1) + call mw_shift (mw, shifts, (2 ** ndim - 1)) + + # Get and reset the axis map. + pdim = mw_stati (mw, MW_NPHYSDIM) + call mw_gaxmap (mw, axno, axval, pdim) + do j = 1, pdim { + if (axno[j] < sdim) { + next + } else if (axno[j] > sdim) { + axno[j] = axno[j] - 1 + } else { + axno[j] = 0 + axval[j] = i - 1 + } + } + call mw_saxmap (mw, axno, axval, pdim) + + call mw_savim (mw, im2) + call mw_close (mw) + } + + call imunmap (im2) + } + + + call imunmap (im1) + call sfree (sp) +end + + +# SL_LOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). + +procedure sl_loop (vs, ve, ldim, fdim, sdim, ndim) + +long vs[ndim] # vector of starting points +long ve[ndim] # vector of ending points +long ldim[ndim] # vector of dimension lengths +int fdim # first dimension +int sdim # slice dimension +int ndim # number of dimensions + +int dim + +begin + for (dim = fdim+1; dim <= ndim; dim = dim + 1) { + if (dim == sdim) + next + vs[dim] = vs[dim] + 1 + ve[dim] = vs[dim] + if (vs[dim] - ldim[dim] == 1) { + if (dim < ndim) { + vs[dim] = 1 + ve[dim] = 1 + } else + break + } else + break + } +end + + +# SL_EINSECTION -- Encode the dimensions of an image where the element of +# the slice dimension is fixed in section notation. + +procedure sl_einsection (im, el, sdim, section, maxch) + +pointer im # pointer to the image +int el # element of last dimension +int sdim # slice dimension +char section[ARB] # output section +int maxch # maximum number of characters in output section + +int i, op +int ltoc(), gstrcat() + +begin + op = 1 + section[1] = '[' + op = op + 1 + + # Encode dimensions up to the slice dimension. + for (i = 1; i <= sdim - 1 && op <= maxch; i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + # Encode the slice dimension. + op = op + ltoc (el, section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + + # Encode dimensions above the slice dimension. + for (i = sdim + 1; i <= IM_NDIM(im); i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + section[op-1] = ']' + section[op] = EOS +end + + +# SL_ESECTION -- Encode the dimensions of an image in section notation. + +procedure sl_esection (im, section, maxch) + +pointer im # pointer to the image +char section[ARB] # output section +int maxch # maximum number of characters in output section + +int i, op +int ltoc(), gstrcat() + +begin + op = 1 + section[1] = '[' + op = op + 1 + + for (i = 1; i <= IM_NDIM(im); i = i + 1) { + op = op + ltoc (long(1), section[op], maxch) + op = op + gstrcat (":", section[op], maxch) + op = op + ltoc (IM_LEN(im,i), section[op], maxch) + op = op + gstrcat (",", section[op], maxch) + } + + section[op-1] = ']' + section[op] = EOS +end diff --git a/pkg/images/imutil/src/t_imstack.x b/pkg/images/imutil/src/t_imstack.x new file mode 100644 index 00000000..20fc1ac7 --- /dev/null +++ b/pkg/images/imutil/src/t_imstack.x @@ -0,0 +1,300 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define NTYPES 7 + + +# T_IMSTACK -- Stack images into a single image of higher dimension. + +procedure t_imstack () + +int i, j, npix, list, pdim, lmax, lindex +int axno[IM_MAXDIM], axval[IM_MAXDIM] +long line_in[IM_MAXDIM], line_out[IM_MAXDIM] +pointer sp, input, output, in, out, buf_in, buf_out, mwin, mwout + +bool envgetb() +int imtopenp(), imtgetim(), imtlen() +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +int mw_stati() +pointer immap(), mw_open(), mw_openim() + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + + # Get the input images and the output image. + list = imtopenp ("images") + call clgstr ("output", Memc[output], SZ_FNAME) + + # Add each input image to the output image. + + i = 0 + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + + i = i + 1 + in = immap (Memc[input], READ_ONLY, 0) + + # For the first input image map the output image as a copy + # and increment the dimension. Set the output line counter. + + if (i == 1) { + out = immap (Memc[output], NEW_COPY, in) + call isk_new_image (out) + IM_NDIM(out) = IM_NDIM(out) + 1 + IM_LEN(out, IM_NDIM(out)) = imtlen (list) + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, IM_MAXDIM) + } + + # Check next input image for consistency with the output image. + if (IM_NDIM(in) != IM_NDIM(out) - 1) + call error (0, "Input images not consistent") + do j = 1, IM_NDIM(in) { + if (IM_LEN(in, j) != IM_LEN(out, j)) + call error (0, "Input images not consistent") + } + + # Copy the input lines from the image to the next lines of + # the output image. Switch on the output data type to optimize + # IMIO. + + call amovkl (long(1), line_in, IM_MAXDIM) + switch (IM_PIXTYPE (out)) { + case TY_SHORT: + while (imgnls (in, buf_in, line_in) != EOF) { + if (impnls (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovs (Mems[buf_in], Mems[buf_out], npix) + } + case TY_INT: + while (imgnli (in, buf_in, line_in) != EOF) { + if (impnli (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovi (Memi[buf_in], Memi[buf_out], npix) + } + case TY_USHORT, TY_LONG: + while (imgnll (in, buf_in, line_in) != EOF) { + if (impnll (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovl (Meml[buf_in], Meml[buf_out], npix) + } + case TY_REAL: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + case TY_DOUBLE: + while (imgnld (in, buf_in, line_in) != EOF) { + if (impnld (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovd (Memd[buf_in], Memd[buf_out], npix) + } + case TY_COMPLEX: + while (imgnlx (in, buf_in, line_in) != EOF) { + if (impnlx (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovx (Memx[buf_in], Memx[buf_out], npix) + } + default: + while (imgnlr (in, buf_in, line_in) != EOF) { + if (impnlr (out, buf_out, line_out) == EOF) + call error (0, "Error writing output image") + call amovr (Memr[buf_in], Memr[buf_out], npix) + } + } + + # Update the wcs. The output image will inherit the wcs of + # the first input image. The new axis will be assigned the + # identity transformation if wcsdim of the original image is + # less than the number of dimensions in the stacked image. + + if ((i == 1) && (! envgetb ("nowcs"))) { + mwin = mw_openim (in) + pdim = mw_stati (mwin, MW_NPHYSDIM) + call mw_gaxmap (mwin, axno, axval, pdim) + lmax = 0 + lindex = 0 + do j = 1, pdim { + if (axno[j] <= lmax) + next + lmax = axno[j] + lindex = j + } + if (lindex < pdim) { + axno[pdim] = lmax + 1 + axval[pdim] = 0 + call mw_saxmap (mwin, axno, axval, pdim) + call mw_saveim (mwin, out) + } else { + mwout = mw_open (NULL, pdim + 1) + call isk_wcs (mwin, mwout, IM_NDIM(out)) + call mw_saveim (mwout, out) + call mw_close (mwout) + } + call mw_close (mwin) + } + + call imunmap (in) + } + + # Finish up. + call imunmap (out) + call imtclose (list) + call sfree (sp) +end + + +# ISK_NEW_IMAGE -- Get a new image title and pixel type. +# +# The strings 'default' or '*' are recognized as defaulting to the original +# title or pixel datatype. + +procedure isk_new_image (im) + +pointer im # image descriptor + +pointer sp, lbuf +int i, type_codes[NTYPES] +bool strne() +int stridx() + +string types "suilrdx" +data type_codes /TY_SHORT,TY_USHORT,TY_INT,TY_LONG,TY_REAL,TY_DOUBLE, + TY_COMPLEX/ + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call clgstr ("title", Memc[lbuf], SZ_LINE) + if (strne (Memc[lbuf], "default") && strne (Memc[lbuf], "*")) + call strcpy (Memc[lbuf], IM_TITLE(im), SZ_IMTITLE) + + call clgstr ("pixtype", Memc[lbuf], SZ_LINE) + if (strne (Memc[lbuf], "default") && strne (Memc[lbuf], "*")) { + i = stridx (Memc[lbuf], types) + if (i != 0) + IM_PIXTYPE(im) = type_codes[i] + } + + call sfree (sp) +end + + +# ISK_WCS -- Update the wcs of the stacked image. + +procedure isk_wcs (mwin, mwout, ndim) + +pointer mwin # input wcs descriptor +pointer mwout # output wcs descriptor +int ndim # the dimension of the output image + +int i, j, nin, nout, szatstr, axno[IM_MAXDIM], axval[IM_MAXDIM] +pointer sp, wcs, attribute, matin, matout, rin, rout, win, wout, atstr +int mw_stati(), itoc(), strlen() +errchk mw_newsystem() + +begin + # Get the sizes of the two wcs. + nin = mw_stati (mwin, MW_NPHYSDIM) + nout = mw_stati (mwout, MW_NPHYSDIM) + szatstr = SZ_LINE + + # Allocate space for the matrices and vectors. + call smark (sp) + call salloc (wcs, SZ_FNAME, TY_CHAR) + call salloc (matin, nin * nin, TY_DOUBLE) + call salloc (matout, nout * nout, TY_DOUBLE) + call salloc (rin, nin, TY_DOUBLE) + call salloc (rout, nout, TY_DOUBLE) + call salloc (win, nin, TY_DOUBLE) + call salloc (wout, nout, TY_DOUBLE) + call salloc (attribute, SZ_FNAME, TY_CHAR) + call malloc (atstr, szatstr, TY_CHAR) + + # Set the system name. + call mw_gsystem (mwin, Memc[wcs], SZ_FNAME) + iferr (call mw_newsystem (mwout, Memc[wcs], nout)) + call mw_ssystem (mwout, Memc[wcs]) + + # Set the lterm. + call mw_gltermd (mwin, Memd[matin], Memd[rin], nin) + call aclrd (Memd[rout], nout) + call amovd (Memd[rin], Memd[rout], nin) + call mw_mkidmd [Memd[matout], nout) + call isk_mcopy (Memd[matin], nin, Memd[matout], nout) + call mw_sltermd (mwout, Memd[matout], Memd[rout], nout) + + # Set the wterm. + call mw_gwtermd (mwin, Memd[rin], Memd[win], Memd[matin], nin) + call aclrd (Memd[rout], nout) + call amovd (Memd[rin], Memd[rout], nin) + call aclrd (Memd[wout], nout) + call amovd (Memd[win], Memd[wout], nin) + call mw_mkidmd [Memd[matout], nout) + call isk_mcopy (Memd[matin], nin, Memd[matout], nout) + call mw_swtermd (mwout, Memd[rout], Memd[wout], Memd[matout], nout) + + # Set the axis map. + call mw_gaxmap (mwin, axno, axval, nin) + do i = nin + 1, nout { + axno[i] = ndim + axval[i] = 0 + } + call mw_saxmap (mwout, axno, axval, nout) + + # Get the axis list and copy the old attribute list for each axis. + do i = 1, nin { + iferr (call mw_gwattrs (mwin, i, "wtype", Memc[atstr], szatstr)) + call strcpy ("linear", Memc[atstr], szatstr) + call mw_swtype (mwout, i, 1, Memc[atstr], "") + for (j = 1; ; j = j + 1) { + if (itoc (j, Memc[attribute], SZ_FNAME) <= 0) + Memc[attribute] = EOS + repeat { + iferr (call mw_gwattrs (mwin, i, Memc[attribute], + Memc[atstr], szatstr)) + Memc[atstr] = EOS + if (strlen (Memc[atstr]) < szatstr) + break + szatstr = szatstr + SZ_LINE + call realloc (atstr, szatstr, TY_CHAR) + } + if (Memc[atstr] == EOS) + break + call mw_swattrs (mwout, i, Memc[attribute], Memc[atstr]) + } + } + + # Set the default attributes for the new axes. + do i = nin + 1, nout + call mw_swtype (mwout, i, 1, "linear", "") + + call mfree (atstr, TY_CHAR) + call sfree (sp) +end + + +# ISK_MCOPY -- Copy a smaller 2d matrix into a larger one. + +procedure isk_mcopy (matin, nin, matout, nout) + +double matin[nin,nin] # the input matrix +int nin # size of the input matrix +double matout[nout,nout] # the input matrix +int nout # size of the output matrix + +int i,j + +begin + do i = 1, nin { + do j = 1, nin + matout[j,i] = matin[j,i] + } +end diff --git a/pkg/images/imutil/src/t_imstat.x b/pkg/images/imutil/src/t_imstat.x new file mode 100644 index 00000000..9641a83e --- /dev/null +++ b/pkg/images/imutil/src/t_imstat.x @@ -0,0 +1,1213 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imstat.h" + + +# T_IMSTATISTICS -- Compute and print the statistics of images. + +procedure t_imstatistics () + +real lower, upper, binwidth, lsigma, usigma, low, up, hwidth, hmin, hmax +pointer sp, fieldstr, fields, image, ist, v +pointer im, buf, hgm +int i, list, nclip, format, nfields, nbins, npix, cache, old_size + +real clgetr() +pointer immap() +int imtopenp(), btoi(), ist_fields(), imtgetim(), imgnlr(), ist_ihist() +int clgeti() +bool clgetb() +errchk immap() + +begin + call smark (sp) + call salloc (fieldstr, SZ_LINE, TY_CHAR) + call salloc (fields, IST_NFIELDS, TY_INT) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (v, IM_MAXDIM, TY_LONG) + + # Open the list of input images, the fields and the data value limits. + list = imtopenp ("images") + call clgstr ("fields", Memc[fieldstr], SZ_LINE) + lower = clgetr ("lower") + upper = clgetr ("upper") + nclip = clgeti ("nclip") + lsigma = clgetr ("lsigma") + usigma = clgetr ("usigma") + binwidth = clgetr ("binwidth") + format = btoi (clgetb ("format")) + cache = btoi (clgetb ("cache")) + + # Allocate space for statistics structure + call ist_allocate (ist) + + # Get the selected fields. + nfields = ist_fields (Memc[fieldstr], Memi[fields], IST_NFIELDS) + if (nfields <= 0) { + call imtclose (list) + call sfree (sp) + return + } + + # Set the processing switches + call ist_switches (ist, Memi[fields], nfields, nclip) + + # Print header banner. + if (format == YES) + call ist_pheader (Memi[fields], nfields) + + # Loop through the input images. + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + + # Open the image. + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + call printf ("Error reading image %s ...\n") + call pargstr (Memc[image]) + next + } + + if (cache == YES) + call ist_cache1 (cache, im, old_size) + + # Accumulate the central moment statistics. + low = lower + up = upper + do i = 0, nclip { + + call ist_initialize (ist, low, up) + call amovkl (long(1), Meml[v], IM_MAXDIM) + + if (IST_SKURTOSIS(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate4 (ist, Memr[buf], + int (IM_LEN(im, 1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SSKEW(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate3 (ist, Memr[buf], + int (IM_LEN (im, 1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SSTDDEV(IST_SW(ist)) == YES || + IST_SMEDIAN(IST_SW(ist)) == YES || + IST_SMODE(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate2 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SMEAN(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate1 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SNPIX(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate0 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, + IST_SMINMAX(IST_SW(ist))) + } else if (IST_SMINMAX(IST_SW(ist)) == YES) { + while (imgnlr (im, buf, Meml[v]) != EOF) + call ist_accumulate0 (ist, Memr[buf], + int (IM_LEN(im,1)), low, up, YES) + } + + + # Compute the central moment statistics. + call ist_stats (ist) + + # Compute new limits and iterate. + if (i < nclip) { + if (IS_INDEFR(lsigma) || IS_INDEFR(IST_MEAN(ist)) || + IS_INDEFR(IST_STDDEV(ist))) + low = -MAX_REAL + else if (lsigma > 0.0) + low = IST_MEAN(ist) - lsigma * IST_STDDEV(ist) + else + low = -MAX_REAL + if (IS_INDEFR(usigma) || IS_INDEFR(IST_MEAN(ist)) || + IS_INDEFR(IST_STDDEV(ist))) + up = MAX_REAL + else if (usigma > 0.0) + up = IST_MEAN(ist) + usigma * IST_STDDEV(ist) + else + up = MAX_REAL + if (!IS_INDEFR(lower)) + low = max (low, lower) + if (!IS_INDEFR(upper)) + up = min (up, upper) + if (i > 0) { + if (IST_NPIX(ist) == npix) + break + } + npix = IST_NPIX(ist) + } + + } + + # Accumulate the histogram. + hgm = NULL + if ((IST_SMEDIAN(IST_SW(ist)) == YES || IST_SMODE(IST_SW(ist)) == + YES) && ist_ihist (ist, binwidth, hgm, nbins, hwidth, hmin, + hmax) == YES) { + call aclri (Memi[hgm], nbins) + call amovkl (long(1), Meml[v], IM_MAXDIM) + while (imgnlr (im, buf, Meml[v]) != EOF) + call ahgmr (Memr[buf], int(IM_LEN(im,1)), Memi[hgm], nbins, + hmin, hmax) + if (IST_SMEDIAN(IST_SW(ist)) == YES) + call ist_hmedian (ist, Memi[hgm], nbins, hwidth, hmin, + hmax) + if (IST_SMODE(IST_SW(ist)) == YES) + call ist_hmode (ist, Memi[hgm], nbins, hwidth, hmin, hmax) + } + if (hgm != NULL) + call mfree (hgm, TY_INT) + + # Print the statistics. + if (format == YES) + call ist_print (Memc[image], "", ist, Memi[fields], nfields) + else + call ist_fprint (Memc[image], "", ist, Memi[fields], nfields) + + call imunmap (im) + if (cache == YES) + call fixmem (old_size) + } + + call ist_free (ist) + call imtclose (list) + call sfree (sp) +end + + +# IST_ALLOCATE -- Allocate space for the statistics structure. + +procedure ist_allocate (ist) + +pointer ist #O the statistics descriptor + +begin + call calloc (ist, LEN_IMSTAT, TY_STRUCT) + call malloc (IST_SW(ist), LEN_NSWITCHES, TY_INT) +end + + +# IST_FREE -- Free the statistics structure. + +procedure ist_free (ist) + +pointer ist #O the statistics descriptor + +begin + call mfree (IST_SW(ist), TY_INT) + call mfree (ist, TY_STRUCT) +end + + +# IST_FIELDS -- Procedure to decode the fields string into a list of the +# fields to be computed and printed. + +int procedure ist_fields (fieldstr, fields, max_nfields) + +char fieldstr[ARB] #I string containing the list of fields +int fields[ARB] #O fields array +int max_nfields #I maximum number of fields + +int nfields, flist, field +pointer sp, fname +int fntopnb(), fntgfnb(), strdic() + +begin + nfields = 0 + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + flist = fntopnb (fieldstr, NO) + while (fntgfnb (flist, Memc[fname], SZ_FNAME) != EOF && + (nfields < max_nfields)) { + field = strdic (Memc[fname], Memc[fname], SZ_FNAME, IST_FIELDS) + if (field == 0) + next + nfields = nfields + 1 + fields[nfields] = field + } + call fntclsb (flist) + + call sfree (sp) + + return (nfields) +end + + +# IST_SWITCHES -- Set the processing switches. + +procedure ist_switches (ist, fields, nfields, nclip) + +pointer ist #I the statistics pointer +int fields[ARB] #I fields array +int nfields #I maximum number of fields +int nclip #I the number of clipping iterations + +pointer sw +int ist_isfield() + +begin + # Initialize. + sw = IST_SW(ist) + call amovki (NO, Memi[sw], LEN_NSWITCHES) + + # Set the computation switches. + IST_SNPIX(sw) = ist_isfield (IST_FNPIX, fields, nfields) + IST_SMEAN(sw) = ist_isfield (IST_FMEAN, fields, nfields) + IST_SMEDIAN(sw) = ist_isfield (IST_FMEDIAN, fields, nfields) + IST_SMODE(sw) = ist_isfield (IST_FMODE, fields, nfields) + if (nclip > 0) + IST_SSTDDEV(sw) = YES + else + IST_SSTDDEV(sw) = ist_isfield (IST_FSTDDEV, fields, nfields) + IST_SSKEW(sw) = ist_isfield (IST_FSKEW, fields, nfields) + IST_SKURTOSIS(sw) = ist_isfield (IST_FKURTOSIS, fields, nfields) + + # Adjust the computation switches. + if (ist_isfield (IST_FMIN, fields, nfields) == YES) + IST_SMINMAX(sw) = YES + else if (ist_isfield (IST_FMAX, fields, nfields) == YES) + IST_SMINMAX(sw) = YES + else if (IST_SMEDIAN(sw) == YES || IST_SMODE(sw) == YES) + IST_SMINMAX(sw) = YES + else + IST_SMINMAX(sw) = NO +end + + +# IST_PHEADER -- Print the banner fields. + +procedure ist_pheader (fields, nfields) + +int fields[ARB] # fields to be printed +int nfields # number of fields + +int i + +begin + call printf ("#") + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf (IST_FSTRING) + call pargstr (IST_KIMAGE) + case IST_FNPIX: + call printf (IST_FCOLUMN) + call pargstr (IST_KNPIX) + case IST_FMIN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMIN) + case IST_FMAX: + call printf (IST_FCOLUMN) + call pargstr (IST_KMAX) + case IST_FMEAN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMEAN) + case IST_FMEDIAN: + call printf (IST_FCOLUMN) + call pargstr (IST_KMEDIAN) + case IST_FMODE: + call printf (IST_FCOLUMN) + call pargstr (IST_KMODE) + case IST_FSTDDEV: + call printf (IST_FCOLUMN) + call pargstr (IST_KSTDDEV) + case IST_FSKEW: + call printf (IST_FCOLUMN) + call pargstr (IST_KSKEW) + case IST_FKURTOSIS: + call printf (IST_FCOLUMN) + call pargstr (IST_KKURTOSIS) + } + } + + call printf ("\n") + call flush (STDOUT) +end + + +# IST_ISFIELD -- Procedure to determine whether a specified field is one +# of the selected fields or not. + +int procedure ist_isfield (field, fields, nfields) + +int field #I field to be tested +int fields[ARB] #I array of selected fields +int nfields #I number of fields + +int i, isfield + +begin + isfield = NO + do i = 1, nfields { + if (field != fields[i]) + next + isfield = YES + break + } + + return (isfield) +end + + +# IST_INITIALIZE -- Initialize the statistics computation. + +procedure ist_initialize (ist, lower, upper) + +pointer ist #I pointer to the statistics structure +real lower #I lower good data limit +real upper #I upper good data limit + +begin + if (IS_INDEFR(lower)) + IST_LO(ist) = -MAX_REAL + else + IST_LO(ist) = lower + if (IS_INDEFR(upper)) + IST_HI(ist) = MAX_REAL + else + IST_HI(ist) = upper + + IST_NPIX(ist) = 0 + IST_SUMX(ist) = 0.0d0 + IST_SUMX2(ist) = 0.0d0 + IST_SUMX3(ist) = 0.0d0 + IST_SUMX4(ist) = 0.0d0 + + IST_MIN(ist) = MAX_REAL + IST_MAX(ist) = -MAX_REAL + IST_MEAN(ist) = INDEFR + IST_MEDIAN(ist) = INDEFR + IST_MODE(ist) = INDEFR + IST_STDDEV(ist) = INDEFR + IST_SKEW(ist) = INDEFR + IST_KURTOSIS(ist) = INDEFR +end + + +# IST_ACCUMULATE4 -- Accumulate sums up to the fourth power of the data for +# data values between lower and upper. + +procedure ist_accumulate4 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, xx2, sumx, sumx2, sumx3, sumx4 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + sumx3 = 0.0 + sumx4 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } else { + do i = 1, npts { + xx = x[i] + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + sumx4 = sumx4 + xx2 * xx2 + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_SUMX3(ist) = IST_SUMX3(ist) + sumx3 + IST_SUMX4(ist) = IST_SUMX4(ist) + sumx4 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE3 -- Accumulate sums up to the third power of the data for +# data values between lower and upper. + +procedure ist_accumulate3 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, xx2, sumx, sumx2, sumx3 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + sumx3 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } else { + do i = 1, npts { + xx = x[i] + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + xx2 = xx * xx + sumx = sumx + xx + sumx2 = sumx2 + xx2 + sumx3 = sumx3 + xx2 * xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_SUMX3(ist) = IST_SUMX3(ist) + sumx3 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE2 -- Accumulate sums up to the second power of the data for +# data values between lower and upper. + +procedure ist_accumulate2 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double xx, sumx, sumx2 +real lo, hi, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + sumx2 = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } else { + do i = 1, npts { + xx = x[i] + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + npix = npix + 1 + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + sumx = sumx + xx + sumx2 = sumx2 + xx * xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_SUMX2(ist) = IST_SUMX2(ist) + sumx2 + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE1 -- Accumulate sums up to the first power of the data for +# data values between lower and upper. + +procedure ist_accumulate1 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +double sumx +real lo, hi, xx, xmin, xmax +int i, npix + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + sumx = 0.0 + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + } + } else { + do i = 1, npts + sumx = sumx + x[i] + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + sumx = sumx + xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + sumx = sumx + xx + } + } + } + + IST_NPIX(ist) = npix + IST_SUMX(ist) = IST_SUMX(ist) + sumx + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_ACCUMULATE0 -- Accumulate sums up to the 0th power of the data for +# data values between lower and upper. + +procedure ist_accumulate0 (ist, x, npts, lower, upper, minmax) + +pointer ist #I pointer to the statistics structure +real x[ARB] #I the data array +int npts #I the number of data points +real lower #I lower data boundary +real upper #I upper data boundary +int minmax #I compute the minimum and maximum ? + +int i, npix +real lo, hi, xx, xmin, xmax + +begin + lo = IST_LO(ist) + hi = IST_HI(ist) + npix = IST_NPIX(ist) + xmin = IST_MIN(ist) + xmax = IST_MAX(ist) + + if (IS_INDEFR(lower) && IS_INDEFR(upper)) { + npix = npix + npts + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + } + } + } else { + if (minmax == YES) { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + if (xx < xmin) + xmin = xx + if (xx > xmax) + xmax = xx + } + } else { + do i = 1, npts { + xx = x[i] + if (xx < lo || xx > hi) + next + npix = npix + 1 + } + } + } + + IST_NPIX(ist) = npix + IST_MIN(ist) = xmin + IST_MAX(ist) = xmax +end + + +# IST_STATS -- Procedure to compute the first four central moments of the +# distribution. + +procedure ist_stats (ist) + +pointer ist #I statistics structure + +double mean, var, stdev +pointer sw +bool fp_equalr() + +begin + sw = IST_SW(ist) + + # Compute the basic statistics regardless of the switches. + if (fp_equalr (IST_MIN(ist), MAX_REAL)) + IST_MIN(ist) = INDEFR + if (fp_equalr (IST_MAX(ist), -MAX_REAL)) + IST_MAX(ist) = INDEFR + if (IST_NPIX(ist) <= 0) + return + + mean = IST_SUMX(ist) / IST_NPIX(ist) + IST_MEAN(ist) = mean + if (IST_NPIX(ist) < 2) + return + + var = (IST_SUMX2(ist) - IST_SUMX(ist) * mean) / + (IST_NPIX(ist) - 1) + if (var <= 0.0) { + IST_STDDEV(ist) = 0.0 + return + } else { + stdev = sqrt (var) + IST_STDDEV(ist) = stdev + } + + # Compute higher order moments if the switches are set. + if (IST_SSKEW(sw)== YES) + IST_SKEW(ist) = (IST_SUMX3(ist) - 3.0d0 * IST_MEAN(ist) * + IST_SUMX2(ist) + 3.0d0 * mean * mean * + IST_SUMX(ist) - IST_NPIX(ist) * mean ** 3) / + IST_NPIX(ist) / stdev / stdev / stdev + + if (IST_SKURTOSIS(sw) == YES) + IST_KURTOSIS(ist) = (IST_SUMX4(ist) - 4.0d0 * mean * + IST_SUMX3(ist) + 6.0d0 * mean * mean * + IST_SUMX2(ist) - 4.0 * mean ** 3 * IST_SUMX(ist) + + IST_NPIX(ist) * mean ** 4) / IST_NPIX(ist) / + stdev / stdev / stdev / stdev - 3.0d0 +end + + + +# IST_IHIST -- Initilaize the histogram of the image pixels. + +int procedure ist_ihist (ist, binwidth, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics structure +real binwidth #I histogram bin width in sigma +pointer hgm #O pointer to the histogram +int nbins #O number of bins +real hwidth #O histogram resolution +real hmin #O minimum histogram value +real hmax #O maximum histogram value + +begin + nbins = 0 + if (binwidth <= 0.0) + return (NO) + + hwidth = binwidth * IST_STDDEV(ist) + if (hwidth <= 0.0) + return (NO) + + nbins = (IST_MAX(ist) - IST_MIN(ist)) / hwidth + 1 + if (nbins < 3) + return (NO) + + hmin = IST_MIN(ist) + hmax = IST_MAX(ist) + + call malloc (hgm, nbins, TY_INT) + + return (YES) +end + + +# IST_HMEDIAN -- Estimate the median from the histogram. + +procedure ist_hmedian (ist, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics structure +int hgm[ARB] #I histogram of the pixels +int nbins #I number of bins in the histogram +real hwidth #I resolution of the histogram +real hmin #I minimum histogram value +real hmax #I maximum histogram value + +real h1, hdiff, hnorm +pointer sp, ihgm +int i, lo, hi + +bool fp_equalr() + +begin + call smark (sp) + call salloc (ihgm, nbins, TY_REAL) + + # Integrate the histogram and normalize. + Memr[ihgm] = hgm[1] + do i = 2, nbins + Memr[ihgm+i-1] = hgm[i] + Memr[ihgm+i-2] + hnorm = Memr[ihgm+nbins-1] + call adivkr (Memr[ihgm], hnorm, Memr[ihgm], nbins) + + # Initialize the low and high bin numbers. + lo = 0 + hi = 1 + + # Search for the point which divides the integral in half. + do i = 1, nbins { + if (Memr[ihgm+i-1] > 0.5) + break + lo = i + } + hi = lo + 1 + + # Approximate the median. + h1 = hmin + lo * hwidth + if (lo == 0) + hdiff = Memr[ihgm+hi-1] + else + hdiff = Memr[ihgm+hi-1] - Memr[ihgm+lo-1] + if (fp_equalr (hdiff, 0.0)) + IST_MEDIAN(ist) = h1 + else if (lo == 0) + IST_MEDIAN(ist) = h1 + 0.5 / hdiff * hwidth + else + IST_MEDIAN(ist) = h1 + (0.5 - Memr[ihgm+lo-1]) / hdiff * hwidth + + call sfree (sp) +end + + +# IST_HMODE -- Procedure to compute the mode. + +procedure ist_hmode (ist, hgm, nbins, hwidth, hmin, hmax) + +pointer ist #I pointer to the statistics strucuture +int hgm[ARB] #I histogram of the pixels +int nbins #I number of bins in the histogram +real hwidth #I resolution of the histogram +real hmin #I minimum histogram value +real hmax #I maximum histogram value + +int i, bpeak +real hpeak, dh1, dh2, denom +bool fp_equalr() + +begin + # If there is a single bin return the midpoint of that bin. + if (nbins == 1) { + IST_MODE(ist) = hmin + 0.5 * hwidth + return + } + + # If there are two bins return the midpoint of the greater bin. + if (nbins == 2) { + if (hgm[1] > hgm[2]) + IST_MODE(ist) = hmin + 0.5 * hwidth + else if (hgm[2] > hgm[1]) + IST_MODE(ist) = hmin + 1.5 * hwidth + else + IST_MODE(ist) = hmin + hwidth + return + } + + # Find the bin containing the histogram maximum. + hpeak = hgm[1] + bpeak = 1 + do i = 2, nbins { + if (hgm[i] > hpeak) { + hpeak = hgm[i] + bpeak = i + } + } + + # If the maximum is in the first bin return the midpoint of the bin. + if (bpeak == 1) { + IST_MODE(ist) = hmin + 0.5 * hwidth + return + } + + # If the maximum is in the last bin return the midpoint of the bin. + if (bpeak == nbins) { + IST_MODE(ist) = hmin + (nbins - 0.5) * hwidth + return + } + + # Compute the lower limit of bpeak. + bpeak = bpeak - 1 + + # Do a parabolic interpolation to find the peak. + dh1 = hgm[bpeak+1] - hgm[bpeak] + dh2 = hgm[bpeak+1] - hgm[bpeak+2] + denom = dh1 + dh2 + if (fp_equalr (denom, 0.0)) { + IST_MODE(ist) = hmin + (bpeak + 0.5) * hwidth + } else { + IST_MODE(ist) = bpeak + 1 + 0.5 * (dh1 - dh2) / denom + IST_MODE(ist) = hmin + (IST_MODE(ist) - 0.5) * hwidth + } + + #dh1 = hgm[bpeak] * (hmin + (bpeak - 0.5) * hwidth) + + #hgm[bpeak+1] * (hmin + (bpeak + 0.5) * hwidth) + + #hgm[bpeak+2] * (hmin + (bpeak + 1.5) * hwidth) + #dh2 = hgm[bpeak] + hgm[bpeak+1] + hgm[bpeak+2] +end + + +# IST_PRINT -- Print the fields using builtin format strings. + +procedure ist_print (image, mask, ist, fields, nfields) + +char image[ARB] #I image name +char mask[ARB] #I mask name +pointer ist #I pointer to the statistics structure +int fields[ARB] #I fields to be printed +int nfields #I number of fields + +int i + +begin + call printf (" ") + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf (IST_FSTRING) + call pargstr (image) + case IST_FNPIX: + call printf (IST_FINTEGER) + call pargi (IST_NPIX(ist)) + case IST_FMIN: + call printf (IST_FREAL) + call pargr (IST_MIN(ist)) + case IST_FMAX: + call printf (IST_FREAL) + call pargr (IST_MAX(ist)) + case IST_FMEAN: + call printf (IST_FREAL) + call pargr (IST_MEAN(ist)) + case IST_FMEDIAN: + call printf (IST_FREAL) + call pargr (IST_MEDIAN(ist)) + case IST_FMODE: + call printf (IST_FREAL) + call pargr (IST_MODE(ist)) + case IST_FSTDDEV: + call printf (IST_FREAL) + call pargr (IST_STDDEV(ist)) + case IST_FSKEW: + call printf (IST_FREAL) + call pargr (IST_SKEW(ist)) + case IST_FKURTOSIS: + call printf (IST_FREAL) + call pargr (IST_KURTOSIS(ist)) + } + } + + call printf ("\n") + call flush (STDOUT) +end + + +# IST_FPRINT -- Print the fields using a free format. + +procedure ist_fprint (image, mask, ist, fields, nfields) + +char image[ARB] #I image name +char mask[ARB] #I mask name +pointer ist #I pointer to the statistics structure +int fields[ARB] #I fields to be printed +int nfields #I number of fields + +int i + +begin + do i = 1, nfields { + switch (fields[i]) { + case IST_FIMAGE: + call printf ("%s") + call pargstr (image) + case IST_FNPIX: + call printf ("%d") + call pargi (IST_NPIX(ist)) + case IST_FMIN: + call printf ("%g") + call pargr (IST_MIN(ist)) + case IST_FMAX: + call printf ("%g") + call pargr (IST_MAX(ist)) + case IST_FMEAN: + call printf ("%g") + call pargr (IST_MEAN(ist)) + case IST_FMEDIAN: + call printf ("%g") + call pargr (IST_MEDIAN(ist)) + case IST_FMODE: + call printf ("%g") + call pargr (IST_MODE(ist)) + case IST_FSTDDEV: + call printf ("%g") + call pargr (IST_STDDEV(ist)) + case IST_FSKEW: + call printf ("%g") + call pargr (IST_SKEW(ist)) + case IST_FKURTOSIS: + call printf ("%g") + call pargr (IST_KURTOSIS(ist)) + } + if (i < nfields) + call printf (" ") + } + + call printf ("\n") + call flush (STDOUT) +end + + +define MEMFUDGE 1.05 + +# IST_CACHE1 -- Cache 1 image in memory using the image i/o buffer sizes. + +procedure ist_cache1 (cache, im, old_size) + +int cache #I cache the image pixels in the imio buffer +pointer im #I the image descriptor +int old_size #O the old working set size + +int i, req_size, buf_size +int sizeof(), ist_memstat() + +begin + req_size = MEMFUDGE * IM_LEN(im,1) * sizeof (IM_PIXTYPE(im)) + do i = 2, IM_NDIM(im) + req_size = req_size * IM_LEN(im,i) + if (ist_memstat (cache, req_size, old_size) == YES) + call ist_pcache (im, INDEFI, buf_size) +end + + +# IST_MEMSTAT -- Figure out if there is enough memory to cache the image +# pixels. If it is necessary to request more memory and the memory is +# avalilable return YES otherwise return NO. + +int procedure ist_memstat (cache, req_size, old_size) + +int cache #I cache memory ? +int req_size #I the requested working set size in chars +int old_size #O the original working set size in chars + +int cur_size, max_size +int begmem() + +begin + # Find the default working set size. + cur_size = begmem (0, old_size, max_size) + + # If cacheing is disabled return NO regardless of the working set size. + if (cache == NO) + return (NO) + + # If the requested working set size is less than the current working + # set size return YES. + if (req_size <= cur_size) + return (YES) + + # Reset the current working set size. + cur_size = begmem (req_size, old_size, max_size) + if (req_size <= cur_size) { + return (YES) + } else { + return (NO) + } +end + + +# IST_PCACHE -- Cache the image pixels im memory by resetting the default image +# buffer size. If req_size is INDEF the size of the image is used to determine +# the size of the image i/o buffers. + +procedure ist_pcache (im, req_size, buf_size) + +pointer im #I the input image point +int req_size #I the requested working set size in chars +int buf_size #O the new image buffer size + +int i, def_size, new_imbufsize +int sizeof(), imstati() + +begin + # Find the default buffer size. + def_size = imstati (im, IM_BUFSIZE) + + # Compute the new required image i/o buffer size in chars. + if (IS_INDEFI(req_size)) { + new_imbufsize = IM_LEN(im,1) * sizeof (IM_PIXTYPE(im)) + do i = 2, IM_NDIM(im) + new_imbufsize = new_imbufsize * IM_LEN(im,i) + } else { + new_imbufsize = req_size + } + + # If the default image i/o buffer size is already bigger than + # the requested size do nothing. + if (def_size >= new_imbufsize) { + buf_size = def_size + return + } + + # Reset the image i/o buffer. + call imseti (im, IM_BUFSIZE, new_imbufsize) + call imseti (im, IM_BUFFRAC, 0) + buf_size = new_imbufsize +end + diff --git a/pkg/images/imutil/src/t_imsum.x b/pkg/images/imutil/src/t_imsum.x new file mode 100644 index 00000000..6e4d0c61 --- /dev/null +++ b/pkg/images/imutil/src/t_imsum.x @@ -0,0 +1,320 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMSUM -- Sum or average images with optional high and low pixel rejection. + +procedure t_imsum () + +int list # Input image list +pointer image # Output image +pointer hparams # Header parameter list +pointer option # Output option +int pixtype # Output pixel datatype +int calctype # Internal calculation type +real low_reject # Number or frac of low pix to reject +real high_reject # Number or frac of high pix to reject + +int i, nimages, nlow, nhigh +pointer sp, str, im_in, im_out + +bool clgetb(), streq() +real clgetr() +int imtopenp(), imtlen(), imtgetim(), clgwrd() +pointer immap() + +errchk imsum_set, immap, imunmap + +begin + # Get the input image list. Check that there is at least 1 image. + list = imtopenp ("input") + nimages = imtlen (list) + if (nimages < 1) { + call imtclose (list) + call error (0, "No input images in list") + } + + # Allocate strings and get the parameters. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (hparams, SZ_LINE, TY_CHAR) + call salloc (option, SZ_LINE, TY_CHAR) + + i = clgwrd ("option", Memc[option], SZ_LINE, "|sum|average|median|") + if (streq (Memc[option], "median")) { + nlow = nimages / 2 + nhigh = nimages - nlow - 1 + } else { + # If the rejection value is less than 1 then it is a fraction of the + # input images otherwise it is the number of pixels to be rejected. + low_reject = clgetr ("low_reject") + high_reject = clgetr ("high_reject") + + if (low_reject < 1.) + nlow = low_reject * nimages + else + nlow = low_reject + + if (high_reject < 1.) + nhigh = high_reject * nimages + else + nhigh = high_reject + + if (nlow + nhigh >= nimages) { + call sfree (sp) + call imtclose (list) + call error (0, "Number of pixels rejected >= number of images") + } + } + call clgstr ("hparams", Memc[hparams], SZ_LINE) + + # Map the output image and set the title and pixel type. + # Check all images have the same number and length of dimensions. + + call imsum_set (list, pixtype, calctype) + + i = imtgetim (list, Memc[image], SZ_FNAME) + im_in = immap (Memc[image], READ_ONLY, 0) + call clgstr ("output", Memc[image], SZ_FNAME) + im_out = immap (Memc[image], NEW_COPY, im_in) + call new_title ("title", im_out) + IM_PIXTYPE (im_out) = pixtype + + call imtrew (list) + + # Print verbose info. + if (clgetb ("verbose")) { + call salloc (str, SZ_LINE, TY_CHAR) + call printf ("IMSUM:\n") + call printf (" Input images:\n") + while (imtgetim (list, Memc[str], SZ_LINE) != EOF) { + call printf (" %s\n") + call pargstr (Memc[str]) + } + call imtrew (list) + call printf (" Output image: %s\n") + call pargstr (Memc[image]) + call printf (" Header parameters: %s\n") + call pargstr (Memc[hparams]) + call printf (" Output pixel datatype: %s\n") + call dtstring (pixtype, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Calculation type: %s\n") + call dtstring (calctype, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call printf (" Option: %s\n") + call pargstr (Memc[option]) + call printf (" Low rejection: %d\n High rejection: %d\n") + call pargi (nlow) + call pargi (nhigh) + call flush (STDOUT) + } + + # Do the image average. Switch on the calculation type. + switch (calctype) { + case TY_SHORT: + call imsums (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_INT: + call imsumi (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_LONG: + call imsuml (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_REAL: + call imsumr (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + case TY_DOUBLE: + call imsumd (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + default: + call imsumr (list, Memc[image], im_out, nlow, nhigh, Memc[option]) + } + call imunmap (im_out) + call imunmap (im_in) + + # Set the header parameters. + call imtrew (list) + call imsum_hparam (list, Memc[image], Memc[hparams], Memc[option]) + + call imtclose (list) + call sfree (sp) +end + +# IMSUM_SET -- Determine the output image pixel type and the calculation +# datatype. The default pixel types are based on the highest arithmetic +# precendence of the input images. + +define NTYPES 5 + +procedure imsum_set (list, pixtype, calctype) + +int list # List of input images +int pixtype # Pixel datatype of output image +int calctype # Pixel datatype for calculations + +int i, j, nimages, max_type +pointer sp, str, im1, im2 + +int imtgetim(), imtlen() +bool xt_imleneq() +pointer immap() +errchk immap, imunmap + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Determine maximum precedence datatype. + # Also check that the images are the same dimension and size. + + nimages = imtlen (list) + j = imtgetim (list, Memc[str], SZ_LINE) + im1 = immap (Memc[str], READ_ONLY, 0) + max_type = IM_PIXTYPE (im1) + + do i = 2, nimages { + j = imtgetim (list, Memc[str], SZ_LINE) + im2 = immap (Memc[str], READ_ONLY, 0) + + if ((IM_NDIM(im1) != IM_NDIM(im2)) || !xt_imleneq (im1, im2)) { + call imunmap (im1) + call imunmap (im2) + call error (0, "Images have different dimensions or sizes") + } + + switch (IM_PIXTYPE (im2)) { + case TY_SHORT: + if (max_type == TY_USHORT) + max_type = TY_INT + case TY_USHORT: + if (max_type == TY_SHORT) + max_type = TY_INT + case TY_INT: + if (max_type == TY_USHORT || max_type == TY_SHORT) + max_type = IM_PIXTYPE (im2) + case TY_LONG: + if (max_type == TY_USHORT || max_type == TY_SHORT || + max_type == TY_INT) + max_type = IM_PIXTYPE (im2) + case TY_REAL: + if (max_type != TY_DOUBLE) + max_type = IM_PIXTYPE (im2) + case TY_DOUBLE: + max_type = IM_PIXTYPE (im2) + default: + } + call imunmap (im2) + } + + call imunmap (im1) + call imtrew (list) + + # Set calculation datatype. + call clgstr ("calctype", Memc[str], SZ_LINE) + switch (Memc[str]) { + case EOS: + calctype = max_type + case 's': + calctype = TY_SHORT + case 'i': + calctype = TY_INT + case 'l': + calctype = TY_LONG + case 'r': + calctype = TY_REAL + case 'd': + calctype = TY_DOUBLE + default: + call error (0, "Unrecognized datatype") + } + + # Set output pixel datatype. + call clgstr ("pixtype", Memc[str], SZ_LINE) + switch (Memc[str]) { + case EOS: + pixtype = calctype + case 'u': + pixtype = TY_USHORT + case 's': + pixtype = TY_SHORT + case 'i': + pixtype = TY_INT + case 'l': + pixtype = TY_LONG + case 'r': + pixtype = TY_REAL + case 'd': + pixtype = TY_DOUBLE + default: + call error (0, "Unrecognized datatype") + } + + call sfree (sp) +end + +# IMSUM_HPARM -- Arithmetic on image header parameters. +# +# This program is limited by a lack of a rewind procedure for the image +# header fields list. Thus, a static array of field names is used +# to require only one pass through the list and the images. + +define NFIELDS 10 # Maximum number of fields allowed. + +procedure imsum_hparam (list, output, hparams, option) + +int list # List of input images. +char output[ARB] # Output image +char hparams[ARB] # List of header parameters +char option[ARB] # Sum option + +int i, nfields, flist +pointer sp, field, dvals, image, in, out + +int imofnlu(), imgnfn(), imtgetim(), imtlen() +bool strne(), streq() +double imgetd() +pointer immap() + +errchk immap, imofnlu, imgetd, imputd, imunmap + +begin + # Return if median. + if (strne (option, "average") && strne (option, "sum")) + return + + # Allocate memory. + call smark (sp) + call salloc (field, NFIELDS*SZ_FNAME, TY_CHAR) + call salloc (dvals, NFIELDS, TY_DOUBLE) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Map the fields. + out = immap (output, READ_WRITE, 0) + flist = imofnlu (out, hparams) + i = 0 + while ((i < NFIELDS) && + (imgnfn (flist, Memc[field+i*SZ_FNAME], SZ_FNAME) != EOF)) + i = i + 1 + call imcfnl (flist) + + # Accumulate values from each image. + + nfields = i + call aclrd (Memd[dvals], nfields) + + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + in = immap (Memc[image], READ_ONLY, 0) + do i = 1, nfields + Memd[dvals+i-1] = Memd[dvals+i-1] + + imgetd (in, Memc[field+(i-1)*SZ_FNAME]) + call imunmap (in) + } + + # Output the sums or average. + if (streq (option, "average")) { + i = imtlen (list) + call adivkd (Memd[dvals], double (i), Memd[dvals], nfields) + } + + do i = 1, nfields + call imputd (out, Memc[field+(i-1)*SZ_FNAME], Memd[dvals+i-1]) + + call imunmap (out) + call sfree (sp) +end diff --git a/pkg/images/imutil/src/t_imtile.x b/pkg/images/imutil/src/t_imtile.x new file mode 100644 index 00000000..92f5cce0 --- /dev/null +++ b/pkg/images/imutil/src/t_imtile.x @@ -0,0 +1,619 @@ +include +include +include "imtile.h" + + +# T_IMTILE -- Combine a list of same-size subrasters into a single large +# mosaiced image. + +procedure t_imtile () + +int nimages, nmissing, subtract, verbose +pointer it, sp, outimage, trimsection, medsection, nullinput, ranges +pointer str, index, c1, c2, l1, l2, isnull, median, imlist, outim + +bool clgetb() +char clgetc() +int btoi(), clgwrd(), imtlen(), clgeti(), decode_ranges(), it_get_imtype() +pointer imtopenp(), it_setim() +real clgetr() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + call malloc (it, LEN_IRSTRUCT, TY_STRUCT) + + # Allocate temporary working space. + call smark (sp) + call salloc (outimage, SZ_FNAME, TY_CHAR) + call salloc (trimsection, SZ_FNAME, TY_CHAR) + call salloc (medsection, SZ_FNAME, TY_CHAR) + call salloc (nullinput, SZ_FNAME, TY_CHAR) + call salloc (ranges, 3 * MAX_NRANGES + 1, TY_INT) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Get the input image list and the output image name. + imlist = imtopenp ("input") + call clgstr ("output", Memc[outimage], SZ_FNAME) + call clgstr ("trim_section", Memc[trimsection], SZ_FNAME) + call clgstr ("missing_input", Memc[nullinput], SZ_FNAME) + call clgstr ("median_section", Memc[medsection], SZ_FNAME) + if (Memc[medsection] == EOS) + subtract = NO + else + subtract = btoi (clgetb ("subtract")) + verbose = btoi (clgetb ("verbose")) + + # Get the mosaicing parameters. + IT_NXSUB(it) = clgeti ("nctile") + IT_NYSUB(it) = clgeti ("nltile") + IT_CORNER(it) = clgwrd ("start_tile", Memc[str], SZ_FNAME, + ",ll,lr,ul,ur,") + if (clgetb ("row_order")) + IT_ORDER(it) = IT_ROW + else + IT_ORDER(it) = IT_COLUMN + IT_RASTER(it) = btoi (clgetb ("raster_order")) + IT_NXOVERLAP(it) = clgeti ("ncoverlap") + IT_NYOVERLAP(it) = clgeti ("nloverlap") + IT_OVAL(it) = clgetr ("ovalue") + + # Check that the number of observed and missing images matches + # the number of specified subrasters. + if (Memc[nullinput] == EOS) { + nmissing = 0 + Memi[ranges] = 0 + Memi[ranges+1] = 0 + Memi[ranges+2] = 1 + Memi[ranges+3] = NULL + } else { + if (decode_ranges (Memc[nullinput], Memi[ranges], MAX_NRANGES, + nmissing) == ERR) + call error (0, "Error decoding list of unobserved rasters.") + } + nimages = imtlen (imlist) + nmissing + if (nimages != (IT_NXSUB(it) * IT_NYSUB(it))) + call error (0, + "The number of input images is not equal to nxsub * nysub.") + + # Compute the output image characteristics and open the output image. + outim = it_setim (it, imlist, Memc[trimsection], Memc[outimage], + clgeti ("ncols"), clgeti ("nlines"), it_get_imtype (clgetc ( + "opixtype"))) + + # Allocate space for and setup the section descriptors. + call salloc (index, nimages, TY_INT) + call salloc (c1, nimages, TY_INT) + call salloc (c2, nimages, TY_INT) + call salloc (l1, nimages, TY_INT) + call salloc (l2, nimages, TY_INT) + call salloc (isnull, nimages, TY_INT) + call salloc (median, nimages, TY_REAL) + + call it_setup (it, imlist, Memi[ranges], Memc[trimsection], + Memc[medsection], outim, Memi[index], Memi[c1], Memi[c2], + Memi[l1], Memi[l2], Memi[isnull], Memr[median]) + + # Make the output image. + call it_mkmosaic (imlist, Memc[trimsection], outim, Memi[index], + Memi[c1], Memi[c2], Memi[l1], Memi[l2], Memi[isnull], + Memr[median], IT_NXSUB(it), IT_NYSUB(it), IT_OVAL(it), subtract) + + # Printe the results. + if (verbose == YES) { + call it_show (imlist, Memc[trimsection], Memc[outimage], + Memi[index], Memi[c1], Memi[c2], Memi[l1], Memi[l2], + Memi[isnull], Memr[median], IT_NXSUB(it)*IT_NYSUB(it), subtract) + } + + # Close up files and free space. + call imunmap (outim) + call clpcls (imlist) + call sfree (sp) + call mfree (it, TY_STRUCT) +end + + +define NTYPES 7 + +# IT_GET_IMTYPE -- Procedure to get the image type. + +int procedure it_get_imtype (c) + +char c # character denoting the image type + +int i, typecodes[NTYPES] +int stridx() +string types "usilrdx" +data typecodes /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE, + TY_COMPLEX/ + +begin + i = stridx (c, types) + if (i == 0) + return (ERR) + else + return (typecodes[i]) +end + + +# IT_SETUP -- Setup the data base parameters for the images. + +procedure it_setup (it, imlist, ranges, trimsection, medsection, outim, + index, c1, c2, l1, l2, isnull, median) + +pointer it # pointer to the imtil structure +pointer imlist # pointer to the list of input images +int ranges[ARB] # list of missing subrasters +char trimsection[ARB] # input image section for output +char medsection[ARB] # input image section for median computation +pointer outim # pointer to the output image +int index[ARB] # index array +int c1[ARB] # array of beginning column limits +int c2[ARB] # array of ending column limits +int l1[ARB] # array of beginning line limits +int l2[ARB] # array of ending line limits +int isnull[ARB] # output input image order number +real median[ARB] # output median of input image + +int i, j, k, nimrows, nimcols, imcount, next_null +pointer sp, imname, im, buf +int get_next_number(), imtgetim() +pointer immap(), imgs2r() +real amedr() + +begin + nimcols = IM_LEN(outim,1) + nimrows = IM_LEN(outim,2) + + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + imcount = 1 + next_null = 0 + if (get_next_number (ranges, next_null) == EOF) + next_null = IT_NXSUB(it) * IT_NYSUB(it) + 1 + + # Loop over the input images. + do i = 1, IT_NXSUB(it) * IT_NYSUB(it) { + + # Set the indices array. + call it_indices (i, j, k, IT_NXSUB(it), IT_NYSUB(it), + IT_CORNER(it), IT_RASTER(it), IT_ORDER(it)) + index[i] = i + c1[i] = max (1, min (1 + (j - 1) * (IT_NCOLS(it) - + IT_NXOVERLAP(it)), nimcols)) + c2[i] = min (nimcols, max (1, c1[i] + IT_NCOLS(it) - 1)) + l1[i] = max (1, min (1 + (k - 1) * (IT_NROWS(it) - + IT_NYOVERLAP(it)), nimrows)) + l2[i] = min (nimrows, max (1, l1[i] + IT_NROWS(it) - 1)) + + # Set the index of each image in the image template + # and compute the median of the subraster. + if (i < next_null) { + isnull[i] = imcount + if (medsection[1] != EOS) { + if (imtgetim (imlist, Memc[imname], SZ_FNAME) == EOF) + call error (0, "Error reading input image list.") + call strcat (medsection, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], READ_ONLY, TY_CHAR) + buf = imgs2r (im, 1, int (IM_LEN(im,1)), 1, int (IM_LEN(im, + 2))) + median[i] = amedr (Memr[buf], int (IM_LEN(im,1)) * + int (IM_LEN(im,2))) + call imunmap (im) + } else + median[i] = INDEFR + imcount = imcount + 1 + } else { + isnull[i] = 0 + if (medsection[1] == EOS) + median[i] = INDEFR + else + median[i] = IT_OVAL(it) + if (get_next_number (ranges, next_null) == EOF) + next_null = IT_NXSUB(it) * IT_NYSUB(it) + 1 + } + + } + + call imtrew (imlist) + call sfree (sp) +end + + +# IT_SETIM -- Procedure to set up the output image characteristics. + +pointer procedure it_setim (it, list, trimsection, outimage, nimcols, nimrows, + opixtype) + +pointer it # pointer to the imtile structure +pointer list # pointer to list of input images +char trimsection[ARB]# input image section +char outimage[ARB] # name of the output image +int nimcols # number of output image columns +int nimrows # number of output image rows +int opixtype # output image pixel type + +int ijunk, nc, nr +pointer sp, imname, im, outim +int imtgetim() +pointer immap() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + # Get the size of the first subraster. + if (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + call strcat (trimsection, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], READ_ONLY, 0) + IT_NCOLS(it) = IM_LEN(im,1) + IT_NROWS(it) = IM_LEN(im,2) + call imunmap (im) + call imtrew (list) + } else + call error (0, "Error reading first input image.\n") + + # Compute the size of the output image. + ijunk = IT_NXSUB(it) * IT_NCOLS(it) - (IT_NXSUB(it) - 1) * + IT_NXOVERLAP(it) + if (IS_INDEFI(nimcols)) + nc = ijunk + else + nc = max (nimcols, ijunk) + ijunk = IT_NYSUB(it) * IT_NROWS(it) - (IT_NYSUB(it) - 1) * + IT_NYOVERLAP(it) + if (IS_INDEFI(ijunk)) + nr = ijunk + else + nr = max (nimrows, ijunk) + + # Set the output pixel type. + if (opixtype == ERR) + opixtype = TY_REAL + + # Open output image and set the parameters. + outim = immap (outimage, NEW_IMAGE, 0) + IM_NDIM(outim) = 2 + IM_LEN(outim,1) = nc + IM_LEN(outim,2) = nr + IM_PIXTYPE(outim) = opixtype + + call sfree (sp) + + return (outim) +end + + +# IT_MKMOSAIC -- Procedure to make the mosaiced image. + +procedure it_mkmosaic (imlist, trimsection, outim, index, c1, c2, l1, l2, + isnull, median, nxsub, nysub, oval, subtract) + +pointer imlist # pointer to input image list +char trimsection[ARB]# input image section +pointer outim # pointer to the output image +int index[ARB] # index array for sorting the images +int c1[ARB] # array of column beginnings +int c2[ARB] # array of column endings +int l1[ARB] # array of line beginnings +int l2[ARB] # array of line endings +int isnull[ARB] # index of input image in the template +real median[ARB] # array of input image median values +int nxsub # number of subrasters per output image column +int nysub # number of subrasters per output image row +real oval # pixel value of undefined output image regions +int subtract # subtract the median off each subraster + +int i, j, noutcols, noutlines, olineptr, ll1, ll2 +pointer sp, inimage, imptrs, buf +int imtrgetim() +pointer immap(), impl2r() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (imptrs, nxsub, TY_POINTER) + call salloc (inimage, SZ_FNAME, TY_CHAR) + + # Sort the subrasters on the yindex. + do i = 1, nxsub * nysub + index[i] = i + call rg_qsorti (l1, index, index, nxsub * nysub) + + noutcols = IM_LEN(outim,1) + noutlines = IM_LEN(outim,2) + + # Loop over the input images. + olineptr = 1 + do i = 1, nxsub * nysub, nxsub { + + # Compute the line and column limits. + ll1 = l1[index[i]] + ll2 = l2[index[i]] + + # Open the nxsub input images. + do j = i, i + nxsub - 1 { + if (isnull[index[j]] <= 0) { + Memc[inimage] = EOS + Memi[imptrs+j-i] = NULL + } else { + if (imtrgetim (imlist, isnull[index[j]], Memc[inimage], + SZ_FNAME) == EOF) + Memi[imptrs+j-i] = NULL + else { + call strcat (trimsection, Memc[inimage], SZ_FNAME) + Memi[imptrs+j-i] = immap (Memc[inimage], READ_ONLY, 0) + } + } + } + + # Write out the undefined lines. + while (olineptr < ll1) { + buf = impl2r (outim, olineptr) + call amovkr (oval, Memr[buf], noutcols) + olineptr = olineptr + 1 + } + + # Write the output lines. + call it_mklines (Memi[imptrs], outim, index, c1, c2, ll1, ll2, + median, i, nxsub, oval, subtract) + olineptr = ll2 + 1 + + # Close up the images. + # Open the nxsub input images. + do j = i, i + nxsub - 1 { + if (Memi[imptrs+j-i] != NULL) + call imunmap (Memi[imptrs+j-i]) + } + + } + + # Write out the remaining undefined lines. + while (olineptr < noutlines) { + buf = impl2r (outim, olineptr) + call amovkr (oval, Memr[buf], noutcols) + olineptr = olineptr + 1 + } + + call sfree (sp) +end + + +# IT_MKLINES -- Construct and output image lines. + +procedure it_mklines (imptrs, outim, index, c1, c2, l1, l2, meds, init, nsub, + oval, subtract) + +pointer imptrs[ARB] # array of input image pointers +pointer outim # output imnage pointer +int index[ARB] # array of indices +int c1[ARB] # array of beginning columns +int c2[ARB] # array of ending columns +int l1 # beginning line +int l2 # ending line +real meds[ARB] # array of median values +int init # first index +int nsub # number of subrasters +real oval # output value +int subtract # subtract the median value + +int i, j, jj, noutcols +pointer obuf, ibuf +pointer impl2r(), imgl2r() + +begin + noutcols = IM_LEN(outim, 1) + do i = l1, l2 { + obuf = impl2r (outim, i) + call amovkr (oval, Memr[obuf], noutcols) + do j = 1, nsub { + jj = index[j+init-1] + if (imptrs[j] != NULL) { + ibuf = imgl2r (imptrs[j], i - l1 + 1) + if (subtract == YES) + call asubkr (Memr[ibuf], meds[jj], Memr[obuf+c1[jj]-1], + c2[jj] - c1[jj] + 1) + else + call amovr (Memr[ibuf], Memr[obuf+c1[jj]-1], c2[jj] - + c1[jj] + 1) + } + } + } +end + + +# IT_INDICES -- Given the number in the list for a missing subraster and +# information about how the subrasters were written return the i and j +# indices of the specified subrasters. + +procedure it_indices (num, i, j, nxsub, nysub, corner, raster, order) + +int num # number of the subraster +int i,j # indices of the subraster +int nxsub,nysub # number of subrasters in x and y +int corner # starting corner +int raster # raster order +int order # column or row order + +begin + switch (corner) { + case IT_LL: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = num / nxsub + if (raster == YES && mod (j,2) == 0) + i = 1 + else + i = nxsub + } else { + j = num / nxsub + 1 + if (raster == YES && mod (j,2) == 0) + i = nxsub - mod (num, nxsub) + 1 + else + i = mod (num, nxsub) + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = num / nysub + if (raster == YES && mod (i,2) == 0) + j = 1 + else + j = nysub + } else { + i = num / nysub + 1 + if (raster == YES && mod (i,2) == 0) + j = nysub - mod (num, nysub) + 1 + else + j = mod (num, nysub) + } + } + case IT_LR: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = num / nxsub + if (raster == YES && mod (j,2) == 0) + i = nxsub + else + i = 1 + } else { + j = num / nxsub + 1 + if (raster == YES && mod (j,2) == 0) + i = mod (num, nxsub) + else + i = nxsub - mod (num, nxsub) + 1 + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = nxsub - num / nysub + 1 + if (raster == YES && mod (i,2) != 0) + j = 1 + else + j = nysub + } else { + i = nxsub - num / nysub + if (raster == YES && mod (i,2) != 0) + j = nysub - mod (num, nysub) + 1 + else + j = mod (num, nysub) + } + } + case IT_UL: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = nysub - num / nxsub + 1 + if (raster == YES && mod (j,2) != 0) + i = 1 + else + i = nxsub + } else { + j = nysub - num / nxsub + if (raster == YES && mod (j,2) != 0) + i = nxsub - mod (num, nxsub) + 1 + else + i = mod (num, nxsub) + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = num / nysub + if (raster == YES && mod (i,2) == 0) + j = nysub + else + j = 1 + } else { + i = num / nysub + 1 + if (raster == YES && mod (i,2) == 0) + j = mod (num, nysub) + else + j = nysub - mod (num, nysub) + 1 + } + } + case IT_UR: + if (order == IT_ROW) { + if (mod (num, nxsub) == 0) { + j = nysub - num / nxsub + 1 + if (raster == YES && mod (j,2) != 0) + i = nxsub + else + i = 1 + } else { + j = nysub - num / nxsub + if (raster == YES && mod (j,2) != 0) + i = mod (num, nxsub) + else + i = nxsub - mod (num, nxsub) + 1 + } + } else if (order == IT_COLUMN) { + if (mod (num, nysub) == 0) { + i = nxsub - num / nysub + 1 + if (raster == YES && mod (i,2) != 0) + j = nysub + else + j = 1 + } else { + i = nxsub - num / nysub + if (raster == YES && mod (i,2) != 0) + j = mod (num, nysub) + else + j = nysub - mod (num, nysub) + 1 + } + } + } +end + + +# IT_SHOW -- List the results. + +procedure it_show (imlist, trimsection, outimage, index, c1, c2, l1, + l2, isnull, median, nsub, subtract) + +int imlist # input image list +char trimsection[ARB]# trim section of input image +char outimage[ARB] # output image +int index[ARB] # array of sorted indices (not used at present) +int c1[ARB] # array of beginning column limits +int c2[ARB] # array of ending column limits +int l1[ARB] # array of beginning line limits +int l2[ARB] # array of ending line limits +int isnull[ARB] # image name index +real median[ARB] # array of medians +int nsub # number of subrasters +int subtract # subtract the median from the subraster + +int i +pointer sp, imname +int imtrgetim() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + do i = 1, nsub { + + if (isnull[i] <= 0) + call strcpy ("nullimage", Memc[imname], SZ_FNAME) + else if (imtrgetim (imlist, isnull[i], Memc[imname], + SZ_FNAME) != EOF) + call strcat (trimsection, Memc[imname], SZ_FNAME) + else + Memc[imname] = EOS + + call printf ("imcopy %s %s[%d:%d,%d:%d] %g %g\n") + call pargstr (Memc[imname]) + call pargstr (outimage) + call pargi (c1[i]) + call pargi (c2[i]) + call pargi (l1[i]) + call pargi (l2[i]) + call pargr (median[i]) + if (subtract == YES) + call pargr (-median[i]) + else + call pargr (0.0) + } + + call sfree (sp) +end + + + diff --git a/pkg/images/imutil/src/t_minmax.x b/pkg/images/imutil/src/t_minmax.x new file mode 100644 index 00000000..03dff18c --- /dev/null +++ b/pkg/images/imutil/src/t_minmax.x @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MINMAX -- Update the minimum and maximum pixel values of an image. This is +# done only if the values are absent or invalid, unless the force flag is set. +# The header values are not updated when computing the min/max of an image +# section unless the force flag is set. The values are printed on the standard +# output as they are computed, if the verbose option is selected. + +procedure t_minmax() + +pointer images # image name template +bool force # force recomputation of values +bool update # update values in image header +bool verbose # print values as they are computed + +bool section +int list, pixtype +long vmin[IM_MAXDIM], vmax[IM_MAXDIM] +pointer im, sp, pixmin, pixmax, imname, imsect +double minval, maxval, iminval, imaxval + +bool clgetb() +long clktime() +int imtopen(), imtgetim() +pointer immap() +define tryagain_ 91 + +begin + call smark (sp) + call salloc (images, SZ_LINE, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (imsect, SZ_FNAME, TY_CHAR) + call salloc (pixmin, SZ_FNAME, TY_CHAR) + call salloc (pixmax, SZ_FNAME, TY_CHAR) + + # Get list of input images. + + call clgstr ("images", Memc[images], SZ_LINE) + list = imtopen (Memc[images]) + + # Get switches. + + force = clgetb ("force") + update = clgetb ("update") + verbose = clgetb ("verbose") + + # Process each image in the list. + + while (imtgetim (list, Memc[imname], SZ_FNAME) != EOF) { + call imgsection (Memc[imname], Memc[imsect], SZ_FNAME) + section = (Memc[imsect] != EOS) + + call strcpy ("", Memc[pixmin], SZ_FNAME) + call strcpy ("", Memc[pixmax], SZ_FNAME) + + if (update) { + + iferr (im = immap (Memc[imname], READ_WRITE, 0)) + goto tryagain_ + + pixtype = IM_PIXTYPE(im) + if (force || (IM_LIMTIME(im) < IM_MTIME(im))) { + if (IM_NDIM(im) > 0) { + call im_vminmax (im, minval, maxval, iminval, imaxval, + vmin, vmax) + call mkoutstr (vmin, IM_NDIM(im), Memc[pixmin], + SZ_FNAME) + call mkoutstr (vmax, IM_NDIM(im), Memc[pixmax], + SZ_FNAME) + } else { + minval = INDEFD + maxval = INDEFD + Memc[pixmin] = EOS + Memc[pixmax] = EOS + } + if (! section) { + if (IS_INDEFD(minval)) + IM_MIN(im) = INDEFR + else + IM_MIN(im) = minval + if (IS_INDEFD(maxval)) + IM_MAX(im) = INDEFR + else + IM_MAX(im) = maxval + IM_LIMTIME(im) = clktime (long(0)) + call imseti (im, IM_WHEADER, YES) + } + } else { + minval = IM_MIN(im) + maxval = IM_MAX(im) + } + + call imunmap (im) + + } else { +tryagain_ iferr (im = immap (Memc[imname], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } else { + pixtype = IM_PIXTYPE(im) + if (force || IM_LIMTIME(im) < IM_MTIME(im)) { + if (IM_NDIM(im) > 0) { + call im_vminmax (im, minval, maxval, iminval, + imaxval, vmin, vmax) + call mkoutstr (vmin, IM_NDIM(im), Memc[pixmin], + SZ_FNAME) + call mkoutstr (vmax, IM_NDIM(im), Memc[pixmax], + SZ_FNAME) + } else { + minval = INDEFD + maxval = INDEFD + Memc[pixmin] = EOS + Memc[pixmax] = EOS + } + } else { + minval = IM_MIN(im) + maxval = IM_MAX(im) + } + call imunmap (im) + } + } + + # Make the section strings. + + if (verbose) { + if (pixtype == TY_COMPLEX) { + call printf (" %s %s %z %s %z\n") + call pargstr (Memc[imname]) + call pargstr (Memc[pixmin]) + call pargx (complex (minval, iminval)) + call pargstr (Memc[pixmax]) + call pargx (complex (maxval, imaxval)) + call flush (STDOUT) + } else { + call printf (" %s %s %g %s %g\n") + call pargstr (Memc[imname]) + call pargstr (Memc[pixmin]) + call pargd (minval) + call pargstr (Memc[pixmax]) + call pargd (maxval) + call flush (STDOUT) + } + } + } + + # Return the computed values of the last image examined as CL + # parameters. + + call clputd ("minval", minval) + call clputd ("maxval", maxval) + call clputd ("iminval", iminval) + call clputd ("imaxval", imaxval) + call clpstr ("minpix", Memc[pixmin]) + call clpstr ("maxpix", Memc[pixmax]) + + call sfree (sp) +end + + +# MKOUTSTR -- Encode the output string. + +procedure mkoutstr (v, ndim, outstr, maxch) + +long v[ARB] # imio v vector +int ndim # number of dimensions +char outstr[ARB] # output string +int maxch # maximum length of string + +int i, ip, nchars +int ltoc() + +begin + # Encode opening brackett. + outstr[1] = '[' + + # Encode v vector values. + ip = 2 + do i = 1, ndim { + nchars = ltoc (v[i], outstr[ip], maxch) + ip = ip + nchars + outstr[ip] = ',' + ip = ip + 1 + } + + # Encode closing bracketts and EOS. + outstr[ip-1] = ']' + outstr[ip] = EOS +end diff --git a/pkg/images/imutil/src/t_sections.x b/pkg/images/imutil/src/t_sections.x new file mode 100644 index 00000000..560e2a2f --- /dev/null +++ b/pkg/images/imutil/src/t_sections.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SECTIONS -- Expand a image template into a list of images on the +# standard output and record the number of sections in a parameter. + +procedure t_sections() + +char images[SZ_LINE] # Image template +char image[SZ_FNAME] +char str[SZ_LINE] +int option, list +int clgwrd(), imtopen(), imtgetim(), imtlen() + +begin + call clgstr ("images", images, SZ_LINE) + option = clgwrd ("option", str, SZ_LINE, + ",nolist,fullname,root,section,") + list = imtopen (images) + + call clputi ("nimages", imtlen (list)) + + while (imtgetim (list, image, SZ_FNAME) != EOF) { + switch (option) { + case 2: + call printf ("%s\n") + call pargstr (image) + case 3: + call get_root (image, str, SZ_LINE) + call printf ("%s\n") + call pargstr (str) + case 4: + call get_section (image, str, SZ_LINE) + call printf ("%s\n") + call pargstr (str) + } + } + + call imtclose (list) +end diff --git a/pkg/images/lib/coomap.key b/pkg/images/lib/coomap.key new file mode 100644 index 00000000..2a44520a --- /dev/null +++ b/pkg/images/lib/coomap.key @@ -0,0 +1,33 @@ + Interactive Keystroke Commands + +? Print options +f Fit data and graph fit with the current graph type (g,x,r,y,s) +g Graph the data and the current fit +x,r Graph the xi fit residuals versus x and y respectively +y,s Graph the eta fit residuals versus x and y respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the line of constant x and y plotting option +t Plot a line of constant x and y through nearest data point +l Print xishift, etashift, xscale, yscale, xrotate, yrotate +q Exit the interactive surface fitting code + + Interactive Colon Commands + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +:show List parameters +:projection Sky projection (lin,tan,arc,sin,tnx, ...) +:refpoint Sky projection reference point +:fit [value] Fit geometry (shift,xyscale,rotate,rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre,polynomial) +:order [value] Xi and Eta fitting orders in x and y +:xxorder [value] Xi fitting function order in x +:xyorder [value] Xi fitting function order in y +:yxorder [value] Eta fitting function order in x +:yyorder [value] Eta fitting function order in y +:xxterms [y/n] Include cross-terms in xi fit +:yxterms [y/n] Include cross-terms in eta fit +:maxiter [value] Maximum number of rejection operations +:reject [value] K-sigma rejection threshold diff --git a/pkg/images/lib/geofit.gx b/pkg/images/lib/geofit.gx new file mode 100644 index 00000000..7aae63a9 --- /dev/null +++ b/pkg/images/lib/geofit.gx @@ -0,0 +1,1605 @@ +# Copyright(c) 1986 Assocation of Universities for Research in Astronomy Inc. + +include +include +include +include "geomap.h" + +$for (r) + +# GEO_MINIT -- Initialize the fitting routines. + +procedure geo_minit (fit, projection, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + +pointer fit #I pointer to the fit structure +int projection #I the coordinate projection type +int geometry #I the fitting geometry +int function #I fitting function +int xxorder #I order of x fit in x +int xyorder #I order of x fit in y +int xxterms #I include cross terms in x fit +int yxorder #I order of y fit in x +int yyorder #I order of y fit in y +int yxterms #I include cross-terms in y fit +int maxiter #I the maximum number of rejection interations +double reject #I rejection threshold in sigma + +begin + # Allocate the space. + call malloc (fit, LEN_GEOMAP, TY_STRUCT) + + # Set function and order. + GM_PROJECTION(fit) = projection + GM_PROJSTR(fit) = EOS + GM_FIT(fit) = geometry + GM_FUNCTION(fit) = function + GM_XXORDER(fit) = xxorder + GM_XYORDER(fit) = xyorder + GM_XXTERMS(fit) = xxterms + GM_YXORDER(fit) = yxorder + GM_YYORDER(fit) = yyorder + GM_YXTERMS(fit) = yxterms + + # Set rejection parameters. + GM_XRMS(fit) = 0.0d0 + GM_YRMS(fit) = 0.0d0 + GM_MAXITER(fit) = maxiter + GM_REJECT(fit) = reject + GM_NREJECT(fit) = 0 + GM_REJ(fit) = NULL + + # Set origin parameters. + GM_XO(fit) = INDEFD + GM_YO(fit) = INDEFD + GM_XOREF(fit) = INDEFD + GM_YOREF(fit) = INDEFD +end + + +# GEO_FREE -- Release the fitting space. + +procedure geo_free (fit) + +pointer fit #I pointer to the fitting structure + +begin + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call mfree (fit, TY_STRUCT) +end + +$endfor + + +$for (rd) + +# GEO_FIT -- Fit the surface in batch. + +procedure geo_fit$t (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, npts, + xerrmsg, yerrmsg, maxch) + +pointer fit #I pointer to fitting structure +pointer sx1, sy1 #U pointer to linear surface +pointer sx2, sy2 #U pointer to higher order correction +PIXEL xref[ARB] #I x reference array +PIXEL yref[ARB] #I y reference array +PIXEL xin[ARB] #I x array +PIXEL yin[ARB] #I y array +PIXEL wts[ARB] #I weight array +int npts #I the number of data points +char xerrmsg[ARB] #O the x fit error message +char yerrmsg[ARB] #O the y fit error message +int maxch #I maximum size of the error message + +pointer sp, xresidual, yresidual +errchk geo_fxy$t(), geo_mreject$t(), geo_ftheta$t(), geo_fmagnify$t() +errchk geo_flinear$t() + +begin + call smark (sp) + call salloc (xresidual, npts, TY_PIXEL) + call salloc (yresidual, npts, TY_PIXEL) + + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_ftheta$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresidual], Mem$t[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnify$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresidual], Mem$t[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinear$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresidual], Mem$t[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxy$t (fit, sx1, sx2, xref, yref, xin, wts, + Mem$t[xresidual], npts, YES, xerrmsg, maxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxy$t (fit, sy1, sy2, xref, yref, yin, wts, + Mem$t[yresidual], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mreject$t (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, + wts, Mem$t[xresidual], Mem$t[yresidual], npts, xerrmsg, + maxch, yerrmsg, maxch) + + call sfree (sp) +end + + +# GEO_FTHETA -- Compute the shift and rotation angle required to match one +# set of coordinates to another. + +procedure geo_ftheta$t (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +PIXEL xref[npts] #I reference image x values +PIXEL yref[npts] #I reference image y values +PIXEL xin[npts] #I input image x values +PIXEL yin[npts] #I input image y values +PIXEL wts[npts] #I array of weights +PIXEL xresid[npts] #O x fit residuals +PIXEL yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, num, denom, theta, det +double ctheta, stheta, cthetax, sthetax, cthetay, sthetay +PIXEL xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_PIXEL) + + # Initialize the fit. +$if (datatype == r) + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) +$else + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) +$endif + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + + } else { + + # Compute the sums required to compute the rotation angle. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + ctheta = cos (theta) + stheta = sin (theta) + if (det < 0.0d0) { + cthetax = -ctheta + sthetay = -stheta + } else { + cthetax = ctheta + sthetay = stheta + } + sthetax = stheta + cthetay = ctheta + + # Compute the x fit coefficients. +$if (datatype == r) + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) +$else + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) +$endif + + # Compute the y fit coefficients. +$if (datatype == r) + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) +$else + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) +$endif + + # Compute the residuals +$if (datatype == r) + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) +$else + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) +$endif + call asub$t (xin, xresid, xresid, npts) + call asub$t (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FMAGNIFY -- Compute the shift, the rotation angle, and the magnification +# factor which is assumed to be the same in x and y, required to match one +# set of coordinates to another. + +procedure geo_fmagnify$t (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +PIXEL xref[npts] #I reference image x values +PIXEL yref[npts] #I reference image y values +PIXEL xin[npts] #I input image x values +PIXEL yin[npts] #I input image y values +PIXEL wts[npts] #I array of weights +PIXEL xresid[npts] #O x fit residuals +PIXEL yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, det, theta +double mag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +PIXEL xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_PIXEL) + + # Initialize the fit. +$if (datatype == r) + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) +$else + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) +$endif + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + + # Compute the sums. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the magnification factor. + ctheta = cos (theta) + stheta = sin (theta) + num = denom * ctheta + num * stheta + denom = sxrxr + syryr + if (denom <= 0.0d0) { + mag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + mag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + if (det < 0.0d0) { + cthetax = -mag * ctheta + sthetay = -mag * stheta + } else { + cthetax = mag * ctheta + sthetay = mag * stheta + } + sthetax = mag * stheta + cthetay = mag * ctheta + + # Compute the x fit coefficients. +$if (datatype == r) + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) +$else + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) +$endif + + # Compute the y fit coefficients. +$if (datatype == r) + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) +$else + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) +$endif + + # Compute the residuals +$if (datatype == r) + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) +$else + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) +$endif + call asub$t (xin, xresid, xresid, npts) + call asub$t (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FLINEAR -- Compute the shift, the rotation angle, and the x and y scale +# factors required to match one set of coordinates to another. + +procedure geo_flinear$t (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +PIXEL xref[npts] #I reference image x values +PIXEL yref[npts] #I reference image y values +PIXEL xin[npts] #I input image x values +PIXEL yin[npts] #I input image y values +PIXEL wts[npts] #I array of weights +PIXEL xresid[npts] #O x fit residuals +PIXEL yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, theta +double xmag, ymag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +PIXEL xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_PIXEL) + + # Initialize the fit. +$if (datatype == r) + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) +$else + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) +$endif + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 3) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = 2.0d0 * (sxrxr * syrxi * syryi - syryr * sxrxi * sxryi) + denom = syryr * (sxrxi - sxryi) * (sxrxi + sxryi) - sxrxr * + (syrxi + syryi) * (syrxi - syryi) + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) / 2.0d0 + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + ctheta = cos (theta) + stheta = sin (theta) + + # Compute the x magnification factor. + num = sxrxi * ctheta - sxryi * stheta + denom = sxrxr + if (denom <= 0.0d0) { + xmag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + xmag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the y magnification factor. + num = syrxi * stheta + syryi * ctheta + denom = syryr + if (denom <= 0.0d0) { + ymag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + ymag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + cthetax = xmag * ctheta + sthetax = ymag * stheta + sthetay = xmag * stheta + cthetay = ymag * ctheta + + # Compute the x fit coefficients. +$if (datatype == r) + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) +$else + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) +$endif + + # Compute the y fit coefficients. +$if (datatype == r) + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) +$else + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) +$endif + + # Compute the residuals +$if (datatype == r) + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) +$else + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) +$endif + call asub$t (xin, xresid, xresid, npts) + call asub$t (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FXY -- Fit the surface. + +procedure geo_fxy$t (fit, sf1, sf2, x, y, z, wts, resid, npts, xfit, errmsg, + maxch) + +pointer fit #I pointer to the fit sturcture +pointer sf1 #U pointer to linear surface +pointer sf2 #U pointer to higher order surface +PIXEL x[npts] #I reference image x values +PIXEL y[npts] #I reference image y values +PIXEL z[npts] #I z values +PIXEL wts[npts] #I array of weights +PIXEL resid[npts] #O fitted residuals +int npts #I number of points +int xfit #I X fit ? +char errmsg[ARB] #O returned error message +int maxch #I maximum number of characters in error message + +int i, ier, ncoeff +pointer sp, zfit, savefit, coeff +PIXEL xmin, xmax, ymin, ymax +bool fp_equald() + +begin + # Allocate working space. + call smark (sp) + call salloc (zfit, npts, TY_PIXEL) + call salloc (savefit, GS_SAVECOEFF + 3, TY_PIXEL) + call salloc (coeff, 3, TY_PIXEL) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Initalize fit +$if (datatype == r) + if (sf1 != NULL) + call gsfree (sf1) + if (sf2 != NULL) + call gsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, x, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 1.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (xmax + xmin) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + if (IS_INDEFD(GM_XO(fit))) + call gsset (sf1, GSXREF, INDEFR) + else + call gsset (sf1, GSXREF, real (GM_XO(fit))) + if (IS_INDEFD(GM_YO(fit))) + call gsset (sf1, GSYREF, INDEFR) + else + call gsset (sf1, GSYREF, real (GM_YO(fit))) + if (IS_INDEFD(GM_ZO(fit))) + call gsset (sf1, GSZREF, INDEFR) + else + call gsset (sf1, GSZREF, real (GM_ZO(fit))) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, y, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = 1.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (ymin + ymax) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + if (IS_INDEFD(GM_XO(fit))) + call gsset (sf1, GSXREF, INDEFR) + else + call gsset (sf1, GSXREF, real (GM_XO(fit))) + if (IS_INDEFD(GM_YO(fit))) + call gsset (sf1, GSYREF, INDEFR) + else + call gsset (sf1, GSYREF, real (GM_YO(fit))) + if (IS_INDEFD(GM_ZO(fit))) + call gsset (sf1, GSZREF, INDEFR) + else + call gsset (sf1, GSZREF, real (GM_ZO(fit))) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + + } + + } + +$else + if (sf1 != NULL) + call dgsfree (sf1) + if (sf2 != NULL) + call dgsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, x, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 1.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (xmax + xmin) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, y, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 1.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (ymin + ymax) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + } + +$endif + + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + +$if (datatype == r) + call gsvector (sf1, x, y, resid, npts) +$else + call dgsvector (sf1, x, y, resid, npts) +$endif + call asub$t (z, resid, resid, npts) + + # Calculate higher order fit. + if (sf2 != NULL) { +$if (datatype == r) + call gsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) +$else + call dgsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) +$endif + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, + "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } +$if (datatype == r) + call gsvector (sf2, x, y, Mem$t[zfit], npts) +$else + call dgsvector (sf2, x, y, Mem$t[zfit], npts) +$endif + call asub$t (resid, Mem$t[zfit], resid, npts) + } + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # calculate the rms of the fit + if (xfit == YES) { + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * resid[i] ** 2 + } else { + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * resid[i] ** 2 + } + + GM_NPTS(fit) = npts + + call sfree (sp) +end + + +# GEO_MREJECT -- Reject points from the fit. + +procedure geo_mreject$t (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, + xresid, yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointers to the linear surface +pointer sx2, sy2 #I pointers to the higher order surface +PIXEL xref[npts] #I reference image x values +PIXEL yref[npts] #I yreference values +PIXEL xin[npts] #I x values +PIXEL yin[npts] #I yvalues +PIXEL wts[npts] #I weights +PIXEL xresid[npts] #I residuals +PIXEL yresid[npts] #I yresiduals +int npts #I number of data points +char xerrmsg[ARB] #O the output x error message +int xmaxch #I maximum number of characters in the x error message +char yerrmsg[ARB] #O the output y error message +int ymaxch #I maximum number of characters in the y error message + +int i +int nreject, niter +pointer sp, twts +PIXEL cutx, cuty +errchk geo_fxy$t(), geo_ftheta$t(), geo_fmagnify$t(), geo_flinear$t() + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_PIXEL) + + # Allocate space for the residuals. + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call malloc (GM_REJ(fit), npts, TY_INT) + GM_NREJECT(fit) = 0 + + # Initialize the temporary weights array and the number of rejected + # points. + call amov$t (wts, Mem$t[twts], npts) + nreject = 0 + + niter = 0 + repeat { + + # Compute the rejection limits. + if ((npts - GM_NWTS0(fit)) > 1) { + cutx = GM_REJECT(fit) * sqrt (GM_XRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + cuty = GM_REJECT(fit) * sqrt (GM_YRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + } else { + cutx = MAX_REAL + cuty = MAX_REAL + } + + # Reject points from the fit. + do i = 1, npts { + if (Mem$t[twts+i-1] > 0.0 && ((abs (xresid[i]) > cutx) || + (abs (yresid[i]) > cuty))) { + Mem$t[twts+i-1] = PIXEL(0.0) + nreject = nreject + 1 + Memi[GM_REJ(fit)+nreject-1] = i + } + } + if ((nreject - GM_NREJECT(fit)) <= 0) + break + GM_NREJECT(fit) = nreject + + # Compute number of deleted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= 0.0) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Recompute the X and Y fit. + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_ftheta$t (fit, sx1, sy1, xref, yref, xin, yin, + Mem$t[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnify$t (fit, sx1, sy1, xref, yref, xin, yin, + Mem$t[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinear$t (fit, sx1, sy1, xref, yref, xin, yin, + Mem$t[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxy$t (fit, sx1, sx2, xref, yref, xin, Mem$t[twts], + xresid, npts, YES, xerrmsg, xmaxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxy$t (fit, sy1, sy2, xref, yref, yin, Mem$t[twts], + yresid, npts, NO, yerrmsg, ymaxch) + } + + # Compute the x fit rms. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + Mem$t[twts+i-1] * xresid[i] ** 2 + + # Compute the y fit rms. + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + Mem$t[twts+i-1] * yresid[i] ** 2 + + niter = niter + 1 + + } until (niter >= GM_MAXITER(fit)) + + call sfree (sp) +end + + +# GEO_MMFREE - Free the space used to fit the surfaces. + +procedure geo_mmfree$t (sx1, sy1, sx2, sy2) + +pointer sx1 #U pointer to the x fits +pointer sy1 #U pointer to the y fit +pointer sx2 #U pointer to the higher order x fit +pointer sy2 #U pointer to the higher order y fit + +begin +$if (datatype == r) + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +$else + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +$endif +end + +$endfor diff --git a/pkg/images/lib/geofit.x b/pkg/images/lib/geofit.x new file mode 100644 index 00000000..0eb82a48 --- /dev/null +++ b/pkg/images/lib/geofit.x @@ -0,0 +1,2539 @@ +# Copyright(c) 1986 Assocation of Universities for Research in Astronomy Inc. + +include +include +include +include "geomap.h" + + + +# GEO_MINIT -- Initialize the fitting routines. + +procedure geo_minit (fit, projection, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + +pointer fit #I pointer to the fit structure +int projection #I the coordinate projection type +int geometry #I the fitting geometry +int function #I fitting function +int xxorder #I order of x fit in x +int xyorder #I order of x fit in y +int xxterms #I include cross terms in x fit +int yxorder #I order of y fit in x +int yyorder #I order of y fit in y +int yxterms #I include cross-terms in y fit +int maxiter #I the maximum number of rejection interations +double reject #I rejection threshold in sigma + +begin + # Allocate the space. + call malloc (fit, LEN_GEOMAP, TY_STRUCT) + + # Set function and order. + GM_PROJECTION(fit) = projection + GM_PROJSTR(fit) = EOS + GM_FIT(fit) = geometry + GM_FUNCTION(fit) = function + GM_XXORDER(fit) = xxorder + GM_XYORDER(fit) = xyorder + GM_XXTERMS(fit) = xxterms + GM_YXORDER(fit) = yxorder + GM_YYORDER(fit) = yyorder + GM_YXTERMS(fit) = yxterms + + # Set rejection parameters. + GM_XRMS(fit) = 0.0d0 + GM_YRMS(fit) = 0.0d0 + GM_MAXITER(fit) = maxiter + GM_REJECT(fit) = reject + GM_NREJECT(fit) = 0 + GM_REJ(fit) = NULL + + # Set origin parameters. + GM_XO(fit) = INDEFD + GM_YO(fit) = INDEFD + GM_XOREF(fit) = INDEFD + GM_YOREF(fit) = INDEFD +end + + +# GEO_FREE -- Release the fitting space. + +procedure geo_free (fit) + +pointer fit #I pointer to the fitting structure + +begin + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call mfree (fit, TY_STRUCT) +end + + + + + + +# GEO_FIT -- Fit the surface in batch. + +procedure geo_fitr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, npts, + xerrmsg, yerrmsg, maxch) + +pointer fit #I pointer to fitting structure +pointer sx1, sy1 #U pointer to linear surface +pointer sx2, sy2 #U pointer to higher order correction +real xref[ARB] #I x reference array +real yref[ARB] #I y reference array +real xin[ARB] #I x array +real yin[ARB] #I y array +real wts[ARB] #I weight array +int npts #I the number of data points +char xerrmsg[ARB] #O the x fit error message +char yerrmsg[ARB] #O the y fit error message +int maxch #I maximum size of the error message + +pointer sp, xresidual, yresidual +errchk geo_fxyr(), geo_mrejectr(), geo_fthetar(), geo_fmagnifyr() +errchk geo_flinearr() + +begin + call smark (sp) + call salloc (xresidual, npts, TY_REAL) + call salloc (yresidual, npts, TY_REAL) + + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, wts, + Memr[xresidual], npts, YES, xerrmsg, maxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, wts, + Memr[yresidual], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, + wts, Memr[xresidual], Memr[yresidual], npts, xerrmsg, + maxch, yerrmsg, maxch) + + call sfree (sp) +end + + +# GEO_FTHETA -- Compute the shift and rotation angle required to match one +# set of coordinates to another. + +procedure geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, num, denom, theta, det +double ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + + } else { + + # Compute the sums required to compute the rotation angle. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + ctheta = cos (theta) + stheta = sin (theta) + if (det < 0.0d0) { + cthetax = -ctheta + sthetay = -stheta + } else { + cthetax = ctheta + sthetay = stheta + } + sthetax = stheta + cthetay = ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FMAGNIFY -- Compute the shift, the rotation angle, and the magnification +# factor which is assumed to be the same in x and y, required to match one +# set of coordinates to another. + +procedure geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, det, theta +double mag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + + # Compute the sums. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the magnification factor. + ctheta = cos (theta) + stheta = sin (theta) + num = denom * ctheta + num * stheta + denom = sxrxr + syryr + if (denom <= 0.0d0) { + mag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + mag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + if (det < 0.0d0) { + cthetax = -mag * ctheta + sthetay = -mag * stheta + } else { + cthetax = mag * ctheta + sthetay = mag * stheta + } + sthetax = mag * stheta + cthetay = mag * ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FLINEAR -- Compute the shift, the rotation angle, and the x and y scale +# factors required to match one set of coordinates to another. + +procedure geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, theta +double xmag, ymag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 3) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = 2.0d0 * (sxrxr * syrxi * syryi - syryr * sxrxi * sxryi) + denom = syryr * (sxrxi - sxryi) * (sxrxi + sxryi) - sxrxr * + (syrxi + syryi) * (syrxi - syryi) + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) / 2.0d0 + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + ctheta = cos (theta) + stheta = sin (theta) + + # Compute the x magnification factor. + num = sxrxi * ctheta - sxryi * stheta + denom = sxrxr + if (denom <= 0.0d0) { + xmag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + xmag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the y magnification factor. + num = syrxi * stheta + syryi * ctheta + denom = syryr + if (denom <= 0.0d0) { + ymag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + ymag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + cthetax = xmag * ctheta + sthetax = ymag * stheta + sthetay = xmag * stheta + cthetay = ymag * ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FXY -- Fit the surface. + +procedure geo_fxyr (fit, sf1, sf2, x, y, z, wts, resid, npts, xfit, errmsg, + maxch) + +pointer fit #I pointer to the fit sturcture +pointer sf1 #U pointer to linear surface +pointer sf2 #U pointer to higher order surface +real x[npts] #I reference image x values +real y[npts] #I reference image y values +real z[npts] #I z values +real wts[npts] #I array of weights +real resid[npts] #O fitted residuals +int npts #I number of points +int xfit #I X fit ? +char errmsg[ARB] #O returned error message +int maxch #I maximum number of characters in error message + +int i, ier, ncoeff +pointer sp, zfit, savefit, coeff +real xmin, xmax, ymin, ymax +bool fp_equald() + +begin + # Allocate working space. + call smark (sp) + call salloc (zfit, npts, TY_REAL) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + call salloc (coeff, 3, TY_REAL) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Initalize fit + if (sf1 != NULL) + call gsfree (sf1) + if (sf2 != NULL) + call gsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, x, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 1.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (xmax + xmin) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + if (IS_INDEFD(GM_XO(fit))) + call gsset (sf1, GSXREF, INDEFR) + else + call gsset (sf1, GSXREF, real (GM_XO(fit))) + if (IS_INDEFD(GM_YO(fit))) + call gsset (sf1, GSYREF, INDEFR) + else + call gsset (sf1, GSYREF, real (GM_YO(fit))) + if (IS_INDEFD(GM_ZO(fit))) + call gsset (sf1, GSZREF, INDEFR) + else + call gsset (sf1, GSZREF, real (GM_ZO(fit))) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, y, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = 1.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (ymin + ymax) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + if (IS_INDEFD(GM_XO(fit))) + call gsset (sf1, GSXREF, INDEFR) + else + call gsset (sf1, GSXREF, real (GM_XO(fit))) + if (IS_INDEFD(GM_YO(fit))) + call gsset (sf1, GSYREF, INDEFR) + else + call gsset (sf1, GSYREF, real (GM_YO(fit))) + if (IS_INDEFD(GM_ZO(fit))) + call gsset (sf1, GSZREF, INDEFR) + else + call gsset (sf1, GSZREF, real (GM_ZO(fit))) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + + } + + } + + + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + + call gsvector (sf1, x, y, resid, npts) + call asubr (z, resid, resid, npts) + + # Calculate higher order fit. + if (sf2 != NULL) { + call gsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, + "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + call gsvector (sf2, x, y, Memr[zfit], npts) + call asubr (resid, Memr[zfit], resid, npts) + } + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # calculate the rms of the fit + if (xfit == YES) { + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * resid[i] ** 2 + } else { + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * resid[i] ** 2 + } + + GM_NPTS(fit) = npts + + call sfree (sp) +end + + +# GEO_MREJECT -- Reject points from the fit. + +procedure geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, + xresid, yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointers to the linear surface +pointer sx2, sy2 #I pointers to the higher order surface +real xref[npts] #I reference image x values +real yref[npts] #I yreference values +real xin[npts] #I x values +real yin[npts] #I yvalues +real wts[npts] #I weights +real xresid[npts] #I residuals +real yresid[npts] #I yresiduals +int npts #I number of data points +char xerrmsg[ARB] #O the output x error message +int xmaxch #I maximum number of characters in the x error message +char yerrmsg[ARB] #O the output y error message +int ymaxch #I maximum number of characters in the y error message + +int i +int nreject, niter +pointer sp, twts +real cutx, cuty +errchk geo_fxyr(), geo_fthetar(), geo_fmagnifyr(), geo_flinearr() + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_REAL) + + # Allocate space for the residuals. + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call malloc (GM_REJ(fit), npts, TY_INT) + GM_NREJECT(fit) = 0 + + # Initialize the temporary weights array and the number of rejected + # points. + call amovr (wts, Memr[twts], npts) + nreject = 0 + + niter = 0 + repeat { + + # Compute the rejection limits. + if ((npts - GM_NWTS0(fit)) > 1) { + cutx = GM_REJECT(fit) * sqrt (GM_XRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + cuty = GM_REJECT(fit) * sqrt (GM_YRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + } else { + cutx = MAX_REAL + cuty = MAX_REAL + } + + # Reject points from the fit. + do i = 1, npts { + if (Memr[twts+i-1] > 0.0 && ((abs (xresid[i]) > cutx) || + (abs (yresid[i]) > cuty))) { + Memr[twts+i-1] = real(0.0) + nreject = nreject + 1 + Memi[GM_REJ(fit)+nreject-1] = i + } + } + if ((nreject - GM_NREJECT(fit)) <= 0) + break + GM_NREJECT(fit) = nreject + + # Compute number of deleted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= 0.0) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Recompute the X and Y fit. + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, Memr[twts], + xresid, npts, YES, xerrmsg, xmaxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, Memr[twts], + yresid, npts, NO, yerrmsg, ymaxch) + } + + # Compute the x fit rms. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + Memr[twts+i-1] * xresid[i] ** 2 + + # Compute the y fit rms. + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + Memr[twts+i-1] * yresid[i] ** 2 + + niter = niter + 1 + + } until (niter >= GM_MAXITER(fit)) + + call sfree (sp) +end + + +# GEO_MMFREE - Free the space used to fit the surfaces. + +procedure geo_mmfreer (sx1, sy1, sx2, sy2) + +pointer sx1 #U pointer to the x fits +pointer sy1 #U pointer to the y fit +pointer sx2 #U pointer to the higher order x fit +pointer sy2 #U pointer to the higher order y fit + +begin + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +end + + + +# GEO_FIT -- Fit the surface in batch. + +procedure geo_fitd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, npts, + xerrmsg, yerrmsg, maxch) + +pointer fit #I pointer to fitting structure +pointer sx1, sy1 #U pointer to linear surface +pointer sx2, sy2 #U pointer to higher order correction +double xref[ARB] #I x reference array +double yref[ARB] #I y reference array +double xin[ARB] #I x array +double yin[ARB] #I y array +double wts[ARB] #I weight array +int npts #I the number of data points +char xerrmsg[ARB] #O the x fit error message +char yerrmsg[ARB] #O the y fit error message +int maxch #I maximum size of the error message + +pointer sp, xresidual, yresidual +errchk geo_fxyd(), geo_mrejectd(), geo_fthetad(), geo_fmagnifyd() +errchk geo_flineard() + +begin + call smark (sp) + call salloc (xresidual, npts, TY_DOUBLE) + call salloc (yresidual, npts, TY_DOUBLE) + + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, wts, + Memd[xresidual], npts, YES, xerrmsg, maxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, wts, + Memd[yresidual], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, + wts, Memd[xresidual], Memd[yresidual], npts, xerrmsg, + maxch, yerrmsg, maxch) + + call sfree (sp) +end + + +# GEO_FTHETA -- Compute the shift and rotation angle required to match one +# set of coordinates to another. + +procedure geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, num, denom, theta, det +double ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + + } else { + + # Compute the sums required to compute the rotation angle. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + ctheta = cos (theta) + stheta = sin (theta) + if (det < 0.0d0) { + cthetax = -ctheta + sthetay = -stheta + } else { + cthetax = ctheta + sthetay = stheta + } + sthetax = stheta + cthetay = ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FMAGNIFY -- Compute the shift, the rotation angle, and the magnification +# factor which is assumed to be the same in x and y, required to match one +# set of coordinates to another. + +procedure geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, det, theta +double mag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + + # Compute the sums. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the magnification factor. + ctheta = cos (theta) + stheta = sin (theta) + num = denom * ctheta + num * stheta + denom = sxrxr + syryr + if (denom <= 0.0d0) { + mag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + mag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + if (det < 0.0d0) { + cthetax = -mag * ctheta + sthetay = -mag * stheta + } else { + cthetax = mag * ctheta + sthetay = mag * stheta + } + sthetax = mag * stheta + cthetay = mag * ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FLINEAR -- Compute the shift, the rotation angle, and the x and y scale +# factors required to match one set of coordinates to another. + +procedure geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, theta +double xmag, ymag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 3) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = 2.0d0 * (sxrxr * syrxi * syryi - syryr * sxrxi * sxryi) + denom = syryr * (sxrxi - sxryi) * (sxrxi + sxryi) - sxrxr * + (syrxi + syryi) * (syrxi - syryi) + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) / 2.0d0 + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + ctheta = cos (theta) + stheta = sin (theta) + + # Compute the x magnification factor. + num = sxrxi * ctheta - sxryi * stheta + denom = sxrxr + if (denom <= 0.0d0) { + xmag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + xmag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the y magnification factor. + num = syrxi * stheta + syryi * ctheta + denom = syryr + if (denom <= 0.0d0) { + ymag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + ymag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + cthetax = xmag * ctheta + sthetax = ymag * stheta + sthetay = xmag * stheta + cthetay = ymag * ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FXY -- Fit the surface. + +procedure geo_fxyd (fit, sf1, sf2, x, y, z, wts, resid, npts, xfit, errmsg, + maxch) + +pointer fit #I pointer to the fit sturcture +pointer sf1 #U pointer to linear surface +pointer sf2 #U pointer to higher order surface +double x[npts] #I reference image x values +double y[npts] #I reference image y values +double z[npts] #I z values +double wts[npts] #I array of weights +double resid[npts] #O fitted residuals +int npts #I number of points +int xfit #I X fit ? +char errmsg[ARB] #O returned error message +int maxch #I maximum number of characters in error message + +int i, ier, ncoeff +pointer sp, zfit, savefit, coeff +double xmin, xmax, ymin, ymax +bool fp_equald() + +begin + # Allocate working space. + call smark (sp) + call salloc (zfit, npts, TY_DOUBLE) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + call salloc (coeff, 3, TY_DOUBLE) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Initalize fit + if (sf1 != NULL) + call dgsfree (sf1) + if (sf2 != NULL) + call dgsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, x, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 1.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (xmax + xmin) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, y, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 1.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (ymin + ymax) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + } + + + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + + call dgsvector (sf1, x, y, resid, npts) + call asubd (z, resid, resid, npts) + + # Calculate higher order fit. + if (sf2 != NULL) { + call dgsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, + "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + call dgsvector (sf2, x, y, Memd[zfit], npts) + call asubd (resid, Memd[zfit], resid, npts) + } + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # calculate the rms of the fit + if (xfit == YES) { + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * resid[i] ** 2 + } else { + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * resid[i] ** 2 + } + + GM_NPTS(fit) = npts + + call sfree (sp) +end + + +# GEO_MREJECT -- Reject points from the fit. + +procedure geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, + xresid, yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointers to the linear surface +pointer sx2, sy2 #I pointers to the higher order surface +double xref[npts] #I reference image x values +double yref[npts] #I yreference values +double xin[npts] #I x values +double yin[npts] #I yvalues +double wts[npts] #I weights +double xresid[npts] #I residuals +double yresid[npts] #I yresiduals +int npts #I number of data points +char xerrmsg[ARB] #O the output x error message +int xmaxch #I maximum number of characters in the x error message +char yerrmsg[ARB] #O the output y error message +int ymaxch #I maximum number of characters in the y error message + +int i +int nreject, niter +pointer sp, twts +double cutx, cuty +errchk geo_fxyd(), geo_fthetad(), geo_fmagnifyd(), geo_flineard() + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_DOUBLE) + + # Allocate space for the residuals. + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call malloc (GM_REJ(fit), npts, TY_INT) + GM_NREJECT(fit) = 0 + + # Initialize the temporary weights array and the number of rejected + # points. + call amovd (wts, Memd[twts], npts) + nreject = 0 + + niter = 0 + repeat { + + # Compute the rejection limits. + if ((npts - GM_NWTS0(fit)) > 1) { + cutx = GM_REJECT(fit) * sqrt (GM_XRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + cuty = GM_REJECT(fit) * sqrt (GM_YRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + } else { + cutx = MAX_REAL + cuty = MAX_REAL + } + + # Reject points from the fit. + do i = 1, npts { + if (Memd[twts+i-1] > 0.0 && ((abs (xresid[i]) > cutx) || + (abs (yresid[i]) > cuty))) { + Memd[twts+i-1] = double(0.0) + nreject = nreject + 1 + Memi[GM_REJ(fit)+nreject-1] = i + } + } + if ((nreject - GM_NREJECT(fit)) <= 0) + break + GM_NREJECT(fit) = nreject + + # Compute number of deleted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= 0.0) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Recompute the X and Y fit. + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, Memd[twts], + xresid, npts, YES, xerrmsg, xmaxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, Memd[twts], + yresid, npts, NO, yerrmsg, ymaxch) + } + + # Compute the x fit rms. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + Memd[twts+i-1] * xresid[i] ** 2 + + # Compute the y fit rms. + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + Memd[twts+i-1] * yresid[i] ** 2 + + niter = niter + 1 + + } until (niter >= GM_MAXITER(fit)) + + call sfree (sp) +end + + +# GEO_MMFREE - Free the space used to fit the surfaces. + +procedure geo_mmfreed (sx1, sy1, sx2, sy2) + +pointer sx1 #U pointer to the x fits +pointer sy1 #U pointer to the y fit +pointer sx2 #U pointer to the higher order x fit +pointer sy2 #U pointer to the higher order y fit + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +end + + diff --git a/pkg/images/lib/geofiti.x b/pkg/images/lib/geofiti.x new file mode 100644 index 00000000..9f11da2b --- /dev/null +++ b/pkg/images/lib/geofiti.x @@ -0,0 +1,2521 @@ +# Copyright(c) 1986 Assocation of Universities for Research in Astronomy Inc. + +include +include +include +include "geomap.h" + + + +# GEO_MINIT -- Initialize the fitting routines. + +procedure geo_minit (fit, projection, geometry, function, xxorder, xyorder, + xxterms, yxorder, yyorder, yxterms, maxiter, reject) + +pointer fit #I pointer to the fit structure +int projection #I the coordinate projection type +int geometry #I the fitting geometry +int function #I fitting function +int xxorder #I order of x fit in x +int xyorder #I order of x fit in y +int xxterms #I include cross terms in x fit +int yxorder #I order of y fit in x +int yyorder #I order of y fit in y +int yxterms #I include cross-terms in y fit +int maxiter #I the maximum number of rejection interations +double reject #I rejection threshold in sigma + +begin + # Allocate the space. + call malloc (fit, LEN_GEOMAP, TY_STRUCT) + + # Set function and order. + GM_PROJECTION(fit) = projection + GM_PROJSTR(fit) = EOS + GM_FIT(fit) = geometry + GM_FUNCTION(fit) = function + GM_XXORDER(fit) = xxorder + GM_XYORDER(fit) = xyorder + GM_XXTERMS(fit) = xxterms + GM_YXORDER(fit) = yxorder + GM_YYORDER(fit) = yyorder + GM_YXTERMS(fit) = yxterms + + # Set rejection parameters. + GM_XRMS(fit) = 0.0d0 + GM_YRMS(fit) = 0.0d0 + GM_MAXITER(fit) = maxiter + GM_REJECT(fit) = reject + GM_NREJECT(fit) = 0 + GM_REJ(fit) = NULL + + # Set origin parameters. + GM_XO(fit) = INDEFD + GM_YO(fit) = INDEFD + GM_XOREF(fit) = INDEFD + GM_YOREF(fit) = INDEFD +end + + +# GEO_FREE -- Release the fitting space. + +procedure geo_free (fit) + +pointer fit #I pointer to the fitting structure + +begin + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call mfree (fit, TY_STRUCT) +end + + + + + + +# GEO_FIT -- Fit the surface in batch. + +procedure geo_fitr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, npts, + xerrmsg, yerrmsg, maxch) + +pointer fit #I pointer to fitting structure +pointer sx1, sy1 #U pointer to linear surface +pointer sx2, sy2 #U pointer to higher order correction +real xref[ARB] #I x reference array +real yref[ARB] #I y reference array +real xin[ARB] #I x array +real yin[ARB] #I y array +real wts[ARB] #I weight array +int npts #I the number of data points +char xerrmsg[ARB] #O the x fit error message +char yerrmsg[ARB] #O the y fit error message +int maxch #I maximum size of the error message + +pointer sp, xresidual, yresidual +errchk geo_fxyr(), geo_mrejectr(), geo_fthetar(), geo_fmagnifyr() +errchk geo_flinearr() + +begin + call smark (sp) + call salloc (xresidual, npts, TY_REAL) + call salloc (yresidual, npts, TY_REAL) + + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresidual], Memr[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, wts, + Memr[xresidual], npts, YES, xerrmsg, maxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, wts, + Memr[yresidual], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, + wts, Memr[xresidual], Memr[yresidual], npts, xerrmsg, + maxch, yerrmsg, maxch) + + call sfree (sp) +end + + +# GEO_FTHETA -- Compute the shift and rotation angle required to match one +# set of coordinates to another. + +procedure geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, num, denom, theta, det +double ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + + } else { + + # Compute the sums required to compute the rotation angle. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + ctheta = cos (theta) + stheta = sin (theta) + if (det < 0.0d0) { + cthetax = -ctheta + sthetay = -stheta + } else { + cthetax = ctheta + sthetay = stheta + } + sthetax = stheta + cthetay = ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FMAGNIFY -- Compute the shift, the rotation angle, and the magnification +# factor which is assumed to be the same in x and y, required to match one +# set of coordinates to another. + +procedure geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, det, theta +double mag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + + # Compute the sums. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the magnification factor. + ctheta = cos (theta) + stheta = sin (theta) + num = denom * ctheta + num * stheta + denom = sxrxr + syryr + if (denom <= 0.0d0) { + mag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + mag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + if (det < 0.0d0) { + cthetax = -mag * ctheta + sthetay = -mag * stheta + } else { + cthetax = mag * ctheta + sthetay = mag * stheta + } + sthetax = mag * stheta + cthetay = mag * ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FLINEAR -- Compute the shift, the rotation angle, and the x and y scale +# factors required to match one set of coordinates to another. + +procedure geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +real xref[npts] #I reference image x values +real yref[npts] #I reference image y values +real xin[npts] #I input image x values +real yin[npts] #I input image y values +real wts[npts] #I array of weights +real xresid[npts] #O x fit residuals +real yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, theta +double xmag, ymag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +real xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + + # Initialize the fit. + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 3) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = 2.0d0 * (sxrxr * syrxi * syryi - syryr * sxrxi * sxryi) + denom = syryr * (sxrxi - sxryi) * (sxrxi + sxryi) - sxrxr * + (syrxi + syryi) * (syrxi - syryi) + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) / 2.0d0 + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + ctheta = cos (theta) + stheta = sin (theta) + + # Compute the x magnification factor. + num = sxrxi * ctheta - sxryi * stheta + denom = sxrxr + if (denom <= 0.0d0) { + xmag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + xmag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the y magnification factor. + num = syrxi * stheta + syryi * ctheta + denom = syryr + if (denom <= 0.0d0) { + ymag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + ymag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + cthetax = xmag * ctheta + sthetax = ymag * stheta + sthetay = xmag * stheta + cthetay = ymag * ctheta + + # Compute the x fit coefficients. + call gsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sx1, Memr[savefit]) + call gsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memr[savefit+GS_SAVECOEFF+1] = cthetax + Memr[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memr[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymax + ymin) / 2 + Memr[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call gsrestore (sx1, Memr[savefit]) + + # Compute the y fit coefficients. + call gsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sy1, Memr[savefit]) + call gsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memr[savefit+GS_SAVECOEFF+1] = -sthetay + Memr[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memr[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymax + ymin) / 2.0 + Memr[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call gsrestore (sy1, Memr[savefit]) + + # Compute the residuals + call gsvector (sx1, xref, yref, xresid, npts) + call gsvector (sy1, xref, yref, yresid, npts) + call asubr (xin, xresid, xresid, npts) + call asubr (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FXY -- Fit the surface. + +procedure geo_fxyr (fit, sf1, sf2, x, y, z, wts, resid, npts, xfit, errmsg, + maxch) + +pointer fit #I pointer to the fit sturcture +pointer sf1 #U pointer to linear surface +pointer sf2 #U pointer to higher order surface +real x[npts] #I reference image x values +real y[npts] #I reference image y values +real z[npts] #I z values +real wts[npts] #I array of weights +real resid[npts] #O fitted residuals +int npts #I number of points +int xfit #I X fit ? +char errmsg[ARB] #O returned error message +int maxch #I maximum number of characters in error message + +int i, ier, ncoeff +pointer sp, zfit, savefit, coeff +real xmin, xmax, ymin, ymax +bool fp_equald() + +begin + # Allocate working space. + call smark (sp) + call salloc (zfit, npts, TY_REAL) + call salloc (savefit, GS_SAVECOEFF + 3, TY_REAL) + call salloc (coeff, 3, TY_REAL) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Initalize fit + if (sf1 != NULL) + call gsfree (sf1) + if (sf2 != NULL) + call gsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, x, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 1.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (xmax + xmin) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0 + Memr[savefit+GS_SAVECOEFF+2] = 0.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gsset (sf1, GSXREF, GM_XO(fit)) + call gsset (sf1, GSYREF, GM_YO(fit)) + call gsset (sf1, GSZREF, GM_ZO(fit)) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gssave (sf1, Memr[savefit]) + call gsfree (sf1) + call gsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubr (z, y, Memr[zfit], npts) + call gsfit (sf1, x, y, Memr[zfit], wts, npts, WTS_USER, ier) + call gscoeff (sf1, Memr[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = 1.0 + } else { + Memr[savefit+GS_SAVECOEFF] = Memr[coeff] + (ymin + ymax) / + 2.0 + Memr[savefit+GS_SAVECOEFF+1] = 0.0 + Memr[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0 + } + call gsfree (sf1) + call gsrestore (sf1, Memr[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call gsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call gsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, + xmax, ymin, ymax) + call gsset (sf1, GSXREF, GM_XO(fit)) + call gsset (sf1, GSYREF, GM_YO(fit)) + call gsset (sf1, GSZREF, GM_ZO(fit)) + call gsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call gsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + + } + + } + + + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + + call gsvector (sf1, x, y, resid, npts) + call asubr (z, resid, resid, npts) + + # Calculate higher order fit. + if (sf2 != NULL) { + call gsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, + "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + call gsvector (sf2, x, y, Memr[zfit], npts) + call asubr (resid, Memr[zfit], resid, npts) + } + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= real(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # calculate the rms of the fit + if (xfit == YES) { + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * resid[i] ** 2 + } else { + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * resid[i] ** 2 + } + + GM_NPTS(fit) = npts + + call sfree (sp) +end + + +# GEO_MREJECT -- Reject points from the fit. + +procedure geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, + xresid, yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointers to the linear surface +pointer sx2, sy2 #I pointers to the higher order surface +real xref[npts] #I reference image x values +real yref[npts] #I yreference values +real xin[npts] #I x values +real yin[npts] #I yvalues +real wts[npts] #I weights +real xresid[npts] #I residuals +real yresid[npts] #I yresiduals +int npts #I number of data points +char xerrmsg[ARB] #O the output x error message +int xmaxch #I maximum number of characters in the x error message +char yerrmsg[ARB] #O the output y error message +int ymaxch #I maximum number of characters in the y error message + +int i +int nreject, niter +pointer sp, twts +real cutx, cuty +errchk geo_fxyr(), geo_fthetar(), geo_fmagnifyr(), geo_flinearr() + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_REAL) + + # Allocate space for the residuals. + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call malloc (GM_REJ(fit), npts, TY_INT) + GM_NREJECT(fit) = 0 + + # Initialize the temporary weights array and the number of rejected + # points. + call amovr (wts, Memr[twts], npts) + nreject = 0 + + niter = 0 + repeat { + + # Compute the rejection limits. + if ((npts - GM_NWTS0(fit)) > 1) { + cutx = GM_REJECT(fit) * sqrt (GM_XRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + cuty = GM_REJECT(fit) * sqrt (GM_YRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + } else { + cutx = MAX_REAL + cuty = MAX_REAL + } + + # Reject points from the fit. + do i = 1, npts { + if (Memr[twts+i-1] > 0.0 && ((abs (xresid[i]) > cutx) || + (abs (yresid[i]) > cuty))) { + Memr[twts+i-1] = real(0.0) + nreject = nreject + 1 + Memi[GM_REJ(fit)+nreject-1] = i + } + } + if ((nreject - GM_NREJECT(fit)) <= 0) + break + GM_NREJECT(fit) = nreject + + # Compute number of deleted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= 0.0) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Recompute the X and Y fit. + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, + Memr[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, Memr[twts], + xresid, npts, YES, xerrmsg, xmaxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, Memr[twts], + yresid, npts, NO, yerrmsg, ymaxch) + } + + # Compute the x fit rms. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + Memr[twts+i-1] * xresid[i] ** 2 + + # Compute the y fit rms. + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + Memr[twts+i-1] * yresid[i] ** 2 + + niter = niter + 1 + + } until (niter >= GM_MAXITER(fit)) + + call sfree (sp) +end + + +# GEO_MMFREE - Free the space used to fit the surfaces. + +procedure geo_mmfreer (sx1, sy1, sx2, sy2) + +pointer sx1 #U pointer to the x fits +pointer sy1 #U pointer to the y fit +pointer sx2 #U pointer to the higher order x fit +pointer sy2 #U pointer to the higher order y fit + +begin + if (sx1 != NULL) + call gsfree (sx1) + if (sy1 != NULL) + call gsfree (sy1) + if (sx2 != NULL) + call gsfree (sx2) + if (sy2 != NULL) + call gsfree (sy2) +end + + + +# GEO_FIT -- Fit the surface in batch. + +procedure geo_fitd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, npts, + xerrmsg, yerrmsg, maxch) + +pointer fit #I pointer to fitting structure +pointer sx1, sy1 #U pointer to linear surface +pointer sx2, sy2 #U pointer to higher order correction +double xref[ARB] #I x reference array +double yref[ARB] #I y reference array +double xin[ARB] #I x array +double yin[ARB] #I y array +double wts[ARB] #I weight array +int npts #I the number of data points +char xerrmsg[ARB] #O the x fit error message +char yerrmsg[ARB] #O the y fit error message +int maxch #I maximum size of the error message + +pointer sp, xresidual, yresidual +errchk geo_fxyd(), geo_mrejectd(), geo_fthetad(), geo_fmagnifyd() +errchk geo_flineard() + +begin + call smark (sp) + call salloc (xresidual, npts, TY_DOUBLE) + call salloc (yresidual, npts, TY_DOUBLE) + + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresidual], Memd[yresidual], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, wts, + Memd[xresidual], npts, YES, xerrmsg, maxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, wts, + Memd[yresidual], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, + wts, Memd[xresidual], Memd[yresidual], npts, xerrmsg, + maxch, yerrmsg, maxch) + + call sfree (sp) +end + + +# GEO_FTHETA -- Compute the shift and rotation angle required to match one +# set of coordinates to another. + +procedure geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, num, denom, theta, det +double ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + + } else { + + # Compute the sums required to compute the rotation angle. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + ctheta = cos (theta) + stheta = sin (theta) + if (det < 0.0d0) { + cthetax = -ctheta + sthetay = -stheta + } else { + cthetax = ctheta + sthetay = stheta + } + sthetax = stheta + cthetay = ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FMAGNIFY -- Compute the shift, the rotation angle, and the magnification +# factor which is assumed to be the same in x and y, required to match one +# set of coordinates to another. + +procedure geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, det, theta +double mag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 2) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + + # Compute the sums. + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = sxrxi * syryi + denom = syrxi * sxryi + if (fp_equald (num, denom)) + det = 0.0d0 + else + det = num - denom + if (det < 0.0d0) { + num = syrxi + sxryi + denom = -sxrxi + syryi + } else { + num = syrxi - sxryi + denom = sxrxi + syryi + } + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the magnification factor. + ctheta = cos (theta) + stheta = sin (theta) + num = denom * ctheta + num * stheta + denom = sxrxr + syryr + if (denom <= 0.0d0) { + mag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + mag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + if (det < 0.0d0) { + cthetax = -mag * ctheta + sthetay = -mag * stheta + } else { + cthetax = mag * ctheta + sthetay = mag * stheta + } + sthetax = mag * stheta + cthetay = mag * ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FLINEAR -- Compute the shift, the rotation angle, and the x and y scale +# factors required to match one set of coordinates to another. + +procedure geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, xresid, + yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit sturcture +pointer sx1 #U pointer to linear x fit surface +pointer sy1 #U pointer to linear y fit surface +double xref[npts] #I reference image x values +double yref[npts] #I reference image y values +double xin[npts] #I input image x values +double yin[npts] #I input image y values +double wts[npts] #I array of weights +double xresid[npts] #O x fit residuals +double yresid[npts] #O y fit residuals +int npts #I number of points +char xerrmsg[ARB] #O returned x fit error message +int xmaxch #I maximum number of characters in x fit error message +char yerrmsg[ARB] #O returned y fit error message +int ymaxch #I maximum number of characters in y fit error message + +int i +double sw, sxr, syr, sxi, syi, xr0, yr0, xi0, yi0 +double syrxi, sxryi, sxrxi, syryi, sxrxr, syryr, num, denom, theta +double xmag, ymag, ctheta, stheta, cthetax, sthetax, cthetay, sthetay +double xmin, xmax, ymin, ymax +pointer sp, savefit +bool fp_equald() + +begin + # Allocate some working space + call smark (sp) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + + # Initialize the fit. + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + + # Determine the minimum and maximum values. + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Compute the sums required to determine the offsets. + sw = 0.0d0 + sxr = 0.0d0 + syr = 0.0d0 + sxi = 0.0d0 + syi = 0.0d0 + do i = 1, npts { + sw = sw + wts[i] + sxr = sxr + wts[i] * xref[i] + syr = syr + wts[i] * yref[i] + sxi = sxi + wts[i] * xin[i] + syi = syi + wts[i] * yin[i] + } + + # Do the fit. + if (sw < 3) { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, + "Too few data points for X and Y fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for X and Y fits.") + call error (1, "Too few data points for X and Y fits.") + } else { + call sprintf (xerrmsg, xmaxch, + "Too few data points for XI and ETA fits.") + call sprintf (yerrmsg, ymaxch, + "Too few data points for XI and ETA fits.") + call error (1, "Too few data points for XI and ETA fits.") + } + } else { + xr0 = sxr / sw + yr0 = syr / sw + xi0 = sxi / sw + yi0 = syi / sw + sxrxr = 0.0d0 + syryr = 0.0d0 + syrxi = 0.0d0 + sxryi = 0.0d0 + sxrxi = 0.0d0 + syryi = 0.0d0 + do i = 1, npts { + sxrxr = sxrxr + wts[i] * (xref[i] - xr0) * (xref[i] - xr0) + syryr = syryr + wts[i] * (yref[i] - yr0) * (yref[i] - yr0) + syrxi = syrxi + wts[i] * (yref[i] - yr0) * (xin[i] - xi0) + sxryi = sxryi + wts[i] * (xref[i] - xr0) * (yin[i] - yi0) + sxrxi = sxrxi + wts[i] * (xref[i] - xr0) * (xin[i] - xi0) + syryi = syryi + wts[i] * (yref[i] - yr0) * (yin[i] - yi0) + } + + # Compute the rotation angle. + num = 2.0d0 * (sxrxr * syrxi * syryi - syryr * sxrxi * sxryi) + denom = syryr * (sxrxi - sxryi) * (sxrxi + sxryi) - sxrxr * + (syrxi + syryi) * (syrxi - syryi) + if (fp_equald (num, 0.0d0) && fp_equald (denom, 0.0d0)) { + theta = 0.0d0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + theta = atan2 (num, denom) / 2.0d0 + if (theta < 0.0d0) + theta = theta + TWOPI + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + ctheta = cos (theta) + stheta = sin (theta) + + # Compute the x magnification factor. + num = sxrxi * ctheta - sxryi * stheta + denom = sxrxr + if (denom <= 0.0d0) { + xmag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + xmag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the y magnification factor. + num = syrxi * stheta + syryi * ctheta + denom = syryr + if (denom <= 0.0d0) { + ymag = 1.0 + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "Warning singular X fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular Y fit.") + } else { + call sprintf (xerrmsg, xmaxch, "Warning singular XI fit.") + call sprintf (yerrmsg, ymaxch, "Warning singular ETA fit.") + } + } else { + ymag = num / denom + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (xerrmsg, xmaxch, "X fit ok.") + call sprintf (yerrmsg, ymaxch, "Y fit ok.") + } else { + call sprintf (xerrmsg, xmaxch, "XI fit ok.") + call sprintf (yerrmsg, ymaxch, "ETA fit ok.") + } + } + + # Compute the polynomial coefficients. + cthetax = xmag * ctheta + sthetax = ymag * stheta + sthetay = xmag * stheta + cthetay = ymag * ctheta + + # Compute the x fit coefficients. + call dgsinit (sx1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sx1, Memd[savefit]) + call dgsfree (sx1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + Memd[savefit+GS_SAVECOEFF+1] = cthetax + Memd[savefit+GS_SAVECOEFF+2] = sthetax + } else { + Memd[savefit+GS_SAVECOEFF] = xi0 - (xr0 * cthetax + yr0 * + sthetax) + cthetax * (xmax + xmin) / 2.0 + sthetax * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = cthetax * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = sthetax * (ymax - ymin) / 2.0 + } + call dgsrestore (sx1, Memd[savefit]) + + # Compute the y fit coefficients. + call dgsinit (sy1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sy1, Memd[savefit]) + call dgsfree (sy1) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) + Memd[savefit+GS_SAVECOEFF+1] = -sthetay + Memd[savefit+GS_SAVECOEFF+2] = cthetay + } else { + Memd[savefit+GS_SAVECOEFF] = yi0 - (-xr0 * sthetay + yr0 * + cthetay) - sthetay * (xmax + xmin) / 2.0 + cthetay * + (ymin + ymax) / 2.0 + Memd[savefit+GS_SAVECOEFF+1] = -sthetay * (xmax - xmin) / 2.0 + Memd[savefit+GS_SAVECOEFF+2] = cthetay * (ymax - ymin) / 2.0 + } + call dgsrestore (sy1, Memd[savefit]) + + # Compute the residuals + call dgsvector (sx1, xref, yref, xresid, npts) + call dgsvector (sy1, xref, yref, yresid, npts) + call asubd (xin, xresid, xresid, npts) + call asubd (yin, yresid, yresid, npts) + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Compute the rms of the x and y fits. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * xresid[i] ** 2 + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * yresid[i] ** 2 + + GM_NPTS(fit) = npts + + } + + call sfree (sp) +end + + +# GEO_FXY -- Fit the surface. + +procedure geo_fxyd (fit, sf1, sf2, x, y, z, wts, resid, npts, xfit, errmsg, + maxch) + +pointer fit #I pointer to the fit sturcture +pointer sf1 #U pointer to linear surface +pointer sf2 #U pointer to higher order surface +double x[npts] #I reference image x values +double y[npts] #I reference image y values +double z[npts] #I z values +double wts[npts] #I array of weights +double resid[npts] #O fitted residuals +int npts #I number of points +int xfit #I X fit ? +char errmsg[ARB] #O returned error message +int maxch #I maximum number of characters in error message + +int i, ier, ncoeff +pointer sp, zfit, savefit, coeff +double xmin, xmax, ymin, ymax +bool fp_equald() + +begin + # Allocate working space. + call smark (sp) + call salloc (zfit, npts, TY_DOUBLE) + call salloc (savefit, GS_SAVECOEFF + 3, TY_DOUBLE) + call salloc (coeff, 3, TY_DOUBLE) + + # Determine the minimum and maximum values + if (fp_equald (GM_XMIN(fit), GM_XMAX(fit))) { + xmin = GM_XMIN(fit) - 0.5d0 + xmax = GM_XMAX(fit) + 0.5d0 + } else { + xmin = GM_XMIN(fit) + xmax = GM_XMAX(fit) + } + if (fp_equald (GM_YMIN(fit), GM_YMAX(fit))) { + ymin = GM_YMIN(fit) - 0.5d0 + ymax = GM_YMAX(fit) + 0.5d0 + } else { + ymin = GM_YMIN(fit) + ymax = GM_YMAX(fit) + } + + # Initalize fit + if (sf1 != NULL) + call dgsfree (sf1) + if (sf2 != NULL) + call dgsfree (sf2) + + if (xfit == YES) { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, x, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 1.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (xmax + xmin) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = (xmax - xmin) / 2.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 0.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_XXORDER(fit) > 2 || GM_XYORDER(fit) > 2 || + GM_XXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_XXORDER(fit), + GM_XYORDER(fit), GM_XXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + + } else { + + switch (GM_FIT(fit)) { + + case GM_SHIFT: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgssave (sf1, Memd[savefit]) + call dgsfree (sf1) + call dgsinit (sf1, GM_FUNCTION(fit), 1, 1, GS_XNONE, xmin, xmax, + ymin, ymax) + call asubd (z, y, Memd[zfit], npts) + call dgsfit (sf1, x, y, Memd[zfit], wts, npts, WTS_USER, ier) + call dgscoeff (sf1, Memd[coeff], ncoeff) + if (GM_FUNCTION(fit) == GS_POLYNOMIAL) { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = 1.0d0 + } else { + Memd[savefit+GS_SAVECOEFF] = Memd[coeff] + (ymin + ymax) / + 2.0d0 + Memd[savefit+GS_SAVECOEFF+1] = 0.0d0 + Memd[savefit+GS_SAVECOEFF+2] = (ymax - ymin) / 2.0d0 + } + call dgsfree (sf1) + call dgsrestore (sf1, Memd[savefit]) + sf2 = NULL + + case GM_XYSCALE: + call dgsinit (sf1, GM_FUNCTION(fit), 1, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + sf2 = NULL + + default: + call dgsinit (sf1, GM_FUNCTION(fit), 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call dgsset (sf1, GSXREF, GM_XO(fit)) + call dgsset (sf1, GSYREF, GM_YO(fit)) + call dgsset (sf1, GSZREF, GM_ZO(fit)) + call dgsfit (sf1, x, y, z, wts, npts, WTS_USER, ier) + if (GM_YXORDER(fit) > 2 || GM_YYORDER(fit) > 2 || + GM_YXTERMS(fit) == GS_XFULL) + call dgsinit (sf2, GM_FUNCTION(fit), GM_YXORDER(fit), + GM_YYORDER(fit), GM_YXTERMS(fit), xmin, xmax, ymin, + ymax) + else + sf2 = NULL + } + } + + + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + + call dgsvector (sf1, x, y, resid, npts) + call asubd (z, resid, resid, npts) + + # Calculate higher order fit. + if (sf2 != NULL) { + call dgsfit (sf2, x, y, resid, wts, npts, WTS_USER, ier) + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for X fit.") + call error (1, "Too few data points for X fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for XI fit.") + call error (1, "Too few data points for XI fit.") + } + } else { + if (GM_PROJECTION(fit) == GM_NONE) { + call sprintf (errmsg, maxch, + "Too few data points for Y fit.") + call error (1, "Too few data points for Y fit.") + } else { + call sprintf (errmsg, maxch, + "Too few data points for ETA fit.") + call error (1, "Too few data points for ETA fit.") + } + } + } else if (ier == SINGULAR) { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular X fit.") + else + call sprintf (errmsg, maxch, "Warning singular XI fit.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Warning singular Y fit.") + else + call sprintf (errmsg, maxch, + "Warning singular ETA fit.") + } + } else { + if (xfit == YES) { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "X fit ok.") + else + call sprintf (errmsg, maxch, "XI fit ok.") + } else { + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (errmsg, maxch, "Y fit ok.") + else + call sprintf (errmsg, maxch, "ETA fit ok.") + } + } + call dgsvector (sf2, x, y, Memd[zfit], npts) + call asubd (resid, Memd[zfit], resid, npts) + } + + # Compute the number of zero weighted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= double(0.0)) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # calculate the rms of the fit + if (xfit == YES) { + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + wts[i] * resid[i] ** 2 + } else { + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + wts[i] * resid[i] ** 2 + } + + GM_NPTS(fit) = npts + + call sfree (sp) +end + + +# GEO_MREJECT -- Reject points from the fit. + +procedure geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, wts, + xresid, yresid, npts, xerrmsg, xmaxch, yerrmsg, ymaxch) + +pointer fit #I pointer to the fit structure +pointer sx1, sy1 #I pointers to the linear surface +pointer sx2, sy2 #I pointers to the higher order surface +double xref[npts] #I reference image x values +double yref[npts] #I yreference values +double xin[npts] #I x values +double yin[npts] #I yvalues +double wts[npts] #I weights +double xresid[npts] #I residuals +double yresid[npts] #I yresiduals +int npts #I number of data points +char xerrmsg[ARB] #O the output x error message +int xmaxch #I maximum number of characters in the x error message +char yerrmsg[ARB] #O the output y error message +int ymaxch #I maximum number of characters in the y error message + +int i +int nreject, niter +pointer sp, twts +double cutx, cuty +errchk geo_fxyd(), geo_fthetad(), geo_fmagnifyd(), geo_flineard() + +begin + # Allocate working space. + call smark (sp) + call salloc (twts, npts, TY_DOUBLE) + + # Allocate space for the residuals. + if (GM_REJ(fit) != NULL) + call mfree (GM_REJ(fit), TY_INT) + call malloc (GM_REJ(fit), npts, TY_INT) + GM_NREJECT(fit) = 0 + + # Initialize the temporary weights array and the number of rejected + # points. + call amovd (wts, Memd[twts], npts) + nreject = 0 + + niter = 0 + repeat { + + # Compute the rejection limits. + if ((npts - GM_NWTS0(fit)) > 1) { + cutx = GM_REJECT(fit) * sqrt (GM_XRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + cuty = GM_REJECT(fit) * sqrt (GM_YRMS(fit) / (npts - + GM_NWTS0(fit) - 1)) + } else { + cutx = MAX_REAL + cuty = MAX_REAL + } + + # Reject points from the fit. + do i = 1, npts { + if (Memd[twts+i-1] > 0.0 && ((abs (xresid[i]) > cutx) || + (abs (yresid[i]) > cuty))) { + Memd[twts+i-1] = double(0.0) + nreject = nreject + 1 + Memi[GM_REJ(fit)+nreject-1] = i + } + } + if ((nreject - GM_NREJECT(fit)) <= 0) + break + GM_NREJECT(fit) = nreject + + # Compute number of deleted points. + GM_NWTS0(fit) = 0 + do i = 1, npts { + if (wts[i] <= 0.0) + GM_NWTS0(fit) = GM_NWTS0(fit) + 1 + } + + # Recompute the X and Y fit. + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, + Memd[twts], xresid, yresid, npts, xerrmsg, xmaxch, + yerrmsg, ymaxch) + sx2 = NULL + sy2 = NULL + default: + GM_ZO(fit) = GM_XOREF(fit) + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, Memd[twts], + xresid, npts, YES, xerrmsg, xmaxch) + GM_ZO(fit) = GM_YOREF(fit) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, Memd[twts], + yresid, npts, NO, yerrmsg, ymaxch) + } + + # Compute the x fit rms. + GM_XRMS(fit) = 0.0d0 + do i = 1, npts + GM_XRMS(fit) = GM_XRMS(fit) + Memd[twts+i-1] * xresid[i] ** 2 + + # Compute the y fit rms. + GM_YRMS(fit) = 0.0d0 + do i = 1, npts + GM_YRMS(fit) = GM_YRMS(fit) + Memd[twts+i-1] * yresid[i] ** 2 + + niter = niter + 1 + + } until (niter >= GM_MAXITER(fit)) + + call sfree (sp) +end + + +# GEO_MMFREE - Free the space used to fit the surfaces. + +procedure geo_mmfreed (sx1, sy1, sx2, sy2) + +pointer sx1 #U pointer to the x fits +pointer sy1 #U pointer to the y fit +pointer sx2 #U pointer to the higher order x fit +pointer sy2 #U pointer to the higher order y fit + +begin + if (sx1 != NULL) + call dgsfree (sx1) + if (sy1 != NULL) + call dgsfree (sy1) + if (sx2 != NULL) + call dgsfree (sx2) + if (sy2 != NULL) + call dgsfree (sy2) +end + + diff --git a/pkg/images/lib/geogmap.gx b/pkg/images/lib/geogmap.gx new file mode 100644 index 00000000..e52a129e --- /dev/null +++ b/pkg/images/lib/geogmap.gx @@ -0,0 +1,494 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "geomap.h" +include "geogmap.h" + +define GHELPFILE "images$lib/geomap.key" +define CHELPFILE "images$lib/coomap.key" + +$for (rd) + +# GEO_MGFIT -- Fit the surface using interactive graphics. + +procedure geo_mgfit$t (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, npts, xerrmsg, yerrmsg, maxch) + +pointer gd #I graphics file descriptor +pointer fit #I pointer to the fit structure +pointer sx1 #I pointer to the linear x surface fit +pointer sy1 #I pointer to the linear y surface fit +pointer sx2 #I pointer to higher order x surface fit +pointer sy2 #I pointer to higher order y surface fit +PIXEL xref[npts] #I the x reference coordinates +PIXEL yref[npts] #I the y reference coordinates +PIXEL xin[npts] #I input x coordinates +PIXEL yin[npts] #I input y coordinates +PIXEL wts[npts] #I array of weights +int npts #I number of data points +char xerrmsg[ARB] #O the output x fit error message +char yerrmsg[ARB] #O the output x fit error message +int maxch #I the size of the error messages + +char errstr[SZ_LINE] +int newgraph, delete, wcs, key, errcode +pointer sp, w, gfit, xresid, yresid, cmd +pointer gt1, gt2, gt3, gt4, gt5 +real wx, wy +PIXEL xshift, yshift, xscale, yscale, thetax, thetay + +int clgcur(), errget() +pointer gt_init() + +errchk geo_fxy$t(), geo_mreject$t(), geo_ftheta$t() +errchk geo_fmagnify$t(), geo_flinear$t() + +begin + # Initialize gfit structure and working space. + call smark (sp) + call salloc (gfit, LEN_GEOGRAPH, TY_STRUCT) + call salloc (xresid, npts, TY_PIXEL) + call salloc (yresid, npts, TY_PIXEL) + call salloc (w, npts, TY_PIXEL) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Do initial fit. + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_ftheta$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresid], Mem$t[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnify$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresid], Mem$t[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinear$t (fit, sx1, sy1, xref, yref, xin, yin, wts, + Mem$t[xresid], Mem$t[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxy$t (fit, sx1, sx2, xref, yref, xin, wts, + Mem$t[xresid], npts, YES, xerrmsg, maxch) + call geo_fxy$t (fit, sy1, sy2, xref, yref, yin, wts, + Mem$t[yresid], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mreject$t (fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, Mem$t[xresid], Mem$t[yresid], npts, xerrmsg, + maxch, yerrmsg, maxch) + } then { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) + call error (2, "Too few points for X and Y fits.") + else + call error (2, "Too few points for XI and ETA fits.") + } + + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + + # Set up plotting defaults. + GG_PLOTTYPE(gfit) = FIT + GG_OVERPLOT(gfit) = NO + GG_CONSTXY(gfit) = YES + newgraph = NO + + # Allocate graphics tools. + gt1 = gt_init () + gt2 = gt_init () + gt3 = gt_init () + gt4 = gt_init () + gt5 = gt_init () + + # Set the plot title and x and y axis labels. + call geo_gtset (FIT, gt1, fit) + call geo_gtset (XXRESID, gt2, fit) + call geo_gtset (XYRESID, gt3, fit) + call geo_gtset (YXRESID, gt4, fit) + call geo_gtset (YYRESID, gt5, fit) + + # Make the first plot. + call gclear (gd) + call geo_label (FIT, gt1, fit) + call geo_1graph$t (gd, gt1, fit, gfit, xref, yref, xin, yin, wts, + npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxy$t (gd, fit, sx1, sy1, sx2, sy2) + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + + # Read the cursor commands. + call amov$t (wts, Mem$t[w], npts) + while (clgcur ("cursor", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != EOF) { + + switch (key) { + + case 'q': + call amov$t (Mem$t[w], wts, npts) + break + + case '?': + if (GM_PROJECTION(fit) == GM_NONE) + call gpagefile (gd, GHELPFILE, "") + else + call gpagefile (gd, CHELPFILE, "") + + case ':': + call geo_colon (gd, fit, gfit, Memc[cmd], newgraph) + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call gt_colon (Memc[cmd], gd, gt1, newgraph) + case XXRESID: + call gt_colon (Memc[cmd], gd, gt2, newgraph) + case XYRESID: + call gt_colon (Memc[cmd], gd, gt3, newgraph) + case YXRESID: + call gt_colon (Memc[cmd], gd, gt4, newgraph) + case YYRESID: + call gt_colon (Memc[cmd], gd, gt5, newgraph) + } + + case 'l': + if (GG_FITERROR(gfit) == NO) { + call geo_lcoeff$t (sx1, sy1, xshift, yshift, xscale, yscale, + thetax, thetay) + call printf ("xshift: %.2f yshift: %.2f ") + call parg$t (xshift) + call parg$t (yshift) + call printf ("xmag: %0.3g ymag: %0.3g ") + call parg$t (xscale) + call parg$t (yscale) + call printf ("xrot: %.2f yrot: %.2f\n") + call parg$t (thetax) + call parg$t (thetay) + } + + case 't': + if (GG_FITERROR(gfit) == NO && GG_PLOTTYPE(gfit) == FIT) + call geo_lxy$t (gd, fit, sx1, sy1, sx2, sy2, xref, yref, + xin, yin, npts, wx, wy) + + case 'c': + if (GG_CONSTXY(gfit) == YES) + GG_CONSTXY(gfit) = NO + else if (GG_CONSTXY(gfit) == NO) + GG_CONSTXY(gfit) = YES + + case 'd', 'u': + if (key == 'd') + delete = YES + else + delete = NO + + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_1delete$t (gd, xin, yin, Mem$t[w], wts, npts, wx, + wy, delete) + case XXRESID: + call geo_2delete$t (gd, xref, Mem$t[xresid], Mem$t[w], wts, + npts, wx, wy, delete) + case XYRESID: + call geo_2delete$t (gd, yref, Mem$t[xresid], Mem$t[w], wts, + npts, wx, wy, delete) + case YXRESID: + call geo_2delete$t (gd, xref, Mem$t[yresid], Mem$t[w], wts, + npts, wx, wy, delete) + case YYRESID: + call geo_2delete$t (gd, yref, Mem$t[yresid], Mem$t[w], wts, + npts, wx, wy, delete) + } + + GG_NEWFUNCTION(gfit) = YES + + case 'g': + if (GG_PLOTTYPE(gfit) != FIT) + newgraph = YES + GG_PLOTTYPE(gfit) = FIT + + case 'x': + if (GG_PLOTTYPE(gfit) != XXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XXRESID + + case 'r': + if (GG_PLOTTYPE(gfit) != XYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XYRESID + + case 'y': + if (GG_PLOTTYPE(gfit) != YXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YXRESID + + case 's': + if (GG_PLOTTYPE(gfit) != YYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YYRESID + + case 'f': + # do fit + if (GG_NEWFUNCTION(gfit) == YES) { + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_ftheta$t (fit, sx1, sy1, xref, yref, xin, + yin, Mem$t[w], Mem$t[xresid], Mem$t[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnify$t (fit, sx1, sy1, xref, yref, xin, + yin, Mem$t[w], Mem$t[xresid], Mem$t[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinear$t (fit, sx1, sy1, xref, yref, xin, + yin, Mem$t[w], Mem$t[xresid], Mem$t[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxy$t (fit, sx1, sx2, xref, yref, xin, + Mem$t[w], Mem$t[xresid], npts, YES, + xerrmsg, maxch) + call geo_fxy$t (fit, sy1, sy2, xref, yref, yin, + Mem$t[w], Mem$t[yresid], npts, NO, + yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mreject$t (fit, sx1, sy1, sx2, sy2, xref, + yref, xin, yin, Mem$t[w], Mem$t[xresid], + Mem$t[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + } then { + errcode = errget (errstr, SZ_LINE) + call printf ("%s\n") + call pargstr (errstr) + GG_FITERROR(gfit) = YES + } + } + + # plot new graph + if (GG_FITERROR(gfit) == YES) + newgraph = NO + else + newgraph = YES + + case 'o': + GG_OVERPLOT(gfit) = YES + + default: + call printf ("\07") + + } + + if (newgraph == YES) { + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_label (FIT, gt1, fit) + call geo_1graph$t (gd, gt1, fit, gfit, xref, yref, xin, yin, + Mem$t[w], npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxy$t (gd, fit, sx1, sy1, sx2, sy2) + case XXRESID: + call geo_label (XXRESID, gt2, fit) + call geo_2graph$t (gd, gt2, fit, gfit, xref, Mem$t[xresid], + Mem$t[w], npts) + case XYRESID: + call geo_label (XYRESID, gt3, fit) + call geo_2graph$t (gd, gt3, fit, gfit, yref, Mem$t[xresid], + Mem$t[w], npts) + case YXRESID: + call geo_label (YXRESID, gt4, fit) + call geo_2graph$t (gd, gt4, fit, gfit, xref, Mem$t[yresid], + Mem$t[w], npts) + case YYRESID: + call geo_label (YYRESID, gt5, fit) + call geo_2graph$t (gd, gt5, fit, gfit, yref, Mem$t[yresid], + Mem$t[w], npts) + } + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + newgraph = NO + } + } + + # Free space. + call gt_free (gt1) + call gt_free (gt2) + call gt_free (gt3) + call gt_free (gt4) + call gt_free (gt5) + call sfree (sp) + + # Call an error if appropriate. + if (errcode > 0) + call error (2, errstr) +end + +# GEO_LCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, xexpansion, yexpansion, x and y rotations. + +procedure geo_lcoeff$t (sx, sy, xshift, yshift, xscale, yscale, xrot, yrot) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +PIXEL xshift #O output x shift +PIXEL yshift #O output y shift +PIXEL xscale #O output x scale +PIXEL yscale #O output y scale +PIXEL xrot #O rotation of point on x axis +PIXEL yrot #O rotation of point on y axis + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +PIXEL xxrange, xyrange, xxmaxmin, xymaxmin +PIXEL yxrange, yyrange, yxmaxmin, yymaxmin +PIXEL a, b, c, d + +bool fp_equal$t() +$if (datatype == r) +int gsgeti() +real gsgetr() +$else +int dgsgeti() +double dgsgetd() +$endif + +begin + # Allocate working space. + call smark (sp) +$if (datatype == r) + call salloc (xcoeff, gsgeti (sx, GSNCOEFF), TY_PIXEL) + call salloc (ycoeff, gsgeti (sy, GSNCOEFF), TY_PIXEL) +$else + call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_PIXEL) + call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_PIXEL) +$endif + + # Get coefficients and numbers of coefficients. +$if (datatype == r) + call gscoeff (sx, Mem$t[xcoeff], nxxcoeff) + call gscoeff (sy, Mem$t[ycoeff], nyycoeff) + nxxcoeff = gsgeti (sx, GSNXCOEFF) + nxycoeff = gsgeti (sx, GSNYCOEFF) + nyxcoeff = gsgeti (sy, GSNXCOEFF) + nyycoeff = gsgeti (sy, GSNYCOEFF) +$else + call dgscoeff (sx, Mem$t[xcoeff], nxxcoeff) + call dgscoeff (sy, Mem$t[ycoeff], nyycoeff) + nxxcoeff = dgsgeti (sx, GSNXCOEFF) + nxycoeff = dgsgeti (sx, GSNYCOEFF) + nyxcoeff = dgsgeti (sy, GSNXCOEFF) + nyycoeff = dgsgeti (sy, GSNYCOEFF) +$endif + + # Get the data range. +$if (datatype == r) + if (gsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (gsgetr (sx, GSXMAX) - gsgetr (sx, GSXMIN)) / 2.0 + xxmaxmin = - (gsgetr (sx, GSXMAX) + gsgetr (sx, GSXMIN)) / 2.0 + xyrange = (gsgetr (sx, GSYMAX) - gsgetr (sx, GSYMIN)) / 2.0 + xymaxmin = - (gsgetr (sx, GSYMAX) + gsgetr (sx, GSYMIN)) / 2.0 +$else + if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 + xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 + xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 + xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 +$endif + } else { + xxrange = PIXEL(1.0) + xxmaxmin = PIXEL(0.0) + xyrange = PIXEL(1.0) + xymaxmin = PIXEL(0.0) + } + +$if (datatype == r) + if (gsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (gsgetr (sy, GSXMAX) - gsgetr (sy, GSXMIN)) / 2.0 + yxmaxmin = - (gsgetr (sy, GSXMAX) + gsgetr (sy, GSXMIN)) / 2.0 + yyrange = (gsgetr (sy, GSYMAX) - gsgetr (sy, GSYMIN)) / 2.0 + yymaxmin = - (gsgetr (sy, GSYMAX) + gsgetr (sy, GSYMIN)) / 2.0 +$else + if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 + yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 + yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 + yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 +$endif + } else { + yxrange = PIXEL(1.0) + yxmaxmin = PIXEL(0.0) + yyrange = PIXEL(1.0) + yymaxmin = PIXEL(0.0) + } + + # Get the shifts. + xshift = Mem$t[xcoeff] + Mem$t[xcoeff+1] * xxmaxmin / xxrange + + Mem$t[xcoeff+2] * xymaxmin / xyrange + yshift = Mem$t[ycoeff] + Mem$t[ycoeff+1] * yxmaxmin / yxrange + + Mem$t[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Mem$t[xcoeff+1] / xxrange + else + a = PIXEL(0.0) + if (nxycoeff > 1) + b = Mem$t[xcoeff+nxxcoeff] / xyrange + else + b = PIXEL(0.0) + if (nyxcoeff > 1) + c = Mem$t[ycoeff+1] / yxrange + else + c = PIXEL(0.0) + if (nyycoeff > 1) + d = Mem$t[ycoeff+nyxcoeff] / yyrange + else + d = PIXEL(0.0) + + # Get the magnification factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equal$t (a, PIXEL(0.0)) && fp_equal$t (c, PIXEL(0.0))) + xrot = PIXEL(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < PIXEL(0.0)) + xrot = xrot + PIXEL(360.0) + + if (fp_equal$t (b, PIXEL(0.0)) && fp_equal$t (d, PIXEL(0.0))) + yrot = PIXEL(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < PIXEL(0.0)) + yrot = yrot + PIXEL(360.0) + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/lib/geogmap.h b/pkg/images/lib/geogmap.h new file mode 100644 index 00000000..7efc3658 --- /dev/null +++ b/pkg/images/lib/geogmap.h @@ -0,0 +1,37 @@ +# Structure definitions for fitting surface graphically + +define LEN_GEOGRAPH 10 + +define GG_NEWFUNCTION Memi[$1] # New function +define GG_PLOTTYPE Memi[$1+1] # Type of plot +define GG_OVERPLOT Memi[$1+2] # Overplot previous graph? +define GG_FITERROR Memi[$1+3] # Error fitting x function +define GG_CONSTXY Memi[$1+4] # Plot lines of constant x-y + +# define plot types + +define FIT 1 # plot x y fit +define XXRESID 2 # x fit residuals versus x +define XYRESID 3 # x fit residuals versus y +define YXRESID 4 # y fit residuals versus x +define YYRESID 5 # y fit residuals versus y + +# define the permitted colon commands + +define GM_CMDS "|show|projection|refpoint|fitgeometry|function|\ +order|xxorder|xyorder|yxorder|yyorder|xxterms|yxterms|reject|maxiter|" + +define GMCMD_SHOW 1 +define GMCMD_PROJECTION 2 +define GMCMD_REFPOINT 3 +define GMCMD_GEOMETRY 4 +define GMCMD_FUNCTION 5 +define GMCMD_ORDER 6 +define GMCMD_XXORDER 7 +define GMCMD_XYORDER 8 +define GMCMD_YXORDER 9 +define GMCMD_YYORDER 10 +define GMCMD_XXTERMS 11 +define GMCMD_YXTERMS 12 +define GMCMD_REJECT 13 +define GMCMD_MAXITER 14 diff --git a/pkg/images/lib/geogmap.x b/pkg/images/lib/geogmap.x new file mode 100644 index 00000000..9dc63610 --- /dev/null +++ b/pkg/images/lib/geogmap.x @@ -0,0 +1,905 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "geomap.h" +include "geogmap.h" + +define GHELPFILE "images$lib/geomap.key" +define CHELPFILE "images$lib/coomap.key" + + + +# GEO_MGFIT -- Fit the surface using interactive graphics. + +procedure geo_mgfitr (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, npts, xerrmsg, yerrmsg, maxch) + +pointer gd #I graphics file descriptor +pointer fit #I pointer to the fit structure +pointer sx1 #I pointer to the linear x surface fit +pointer sy1 #I pointer to the linear y surface fit +pointer sx2 #I pointer to higher order x surface fit +pointer sy2 #I pointer to higher order y surface fit +real xref[npts] #I the x reference coordinates +real yref[npts] #I the y reference coordinates +real xin[npts] #I input x coordinates +real yin[npts] #I input y coordinates +real wts[npts] #I array of weights +int npts #I number of data points +char xerrmsg[ARB] #O the output x fit error message +char yerrmsg[ARB] #O the output x fit error message +int maxch #I the size of the error messages + +char errstr[SZ_LINE] +int newgraph, delete, wcs, key, errcode +pointer sp, w, gfit, xresid, yresid, cmd +pointer gt1, gt2, gt3, gt4, gt5 +real wx, wy +real xshift, yshift, xscale, yscale, thetax, thetay + +int clgcur(), errget() +pointer gt_init() + +errchk geo_fxyr(), geo_mrejectr(), geo_fthetar() +errchk geo_fmagnifyr(), geo_flinearr() + +begin + # Initialize gfit structure and working space. + call smark (sp) + call salloc (gfit, LEN_GEOGRAPH, TY_STRUCT) + call salloc (xresid, npts, TY_REAL) + call salloc (yresid, npts, TY_REAL) + call salloc (w, npts, TY_REAL) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Do initial fit. + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, wts, + Memr[xresid], npts, YES, xerrmsg, maxch) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, wts, + Memr[yresid], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, Memr[xresid], Memr[yresid], npts, xerrmsg, + maxch, yerrmsg, maxch) + } then { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) + call error (2, "Too few points for X and Y fits.") + else + call error (2, "Too few points for XI and ETA fits.") + } + + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + + # Set up plotting defaults. + GG_PLOTTYPE(gfit) = FIT + GG_OVERPLOT(gfit) = NO + GG_CONSTXY(gfit) = YES + newgraph = NO + + # Allocate graphics tools. + gt1 = gt_init () + gt2 = gt_init () + gt3 = gt_init () + gt4 = gt_init () + gt5 = gt_init () + + # Set the plot title and x and y axis labels. + call geo_gtset (FIT, gt1, fit) + call geo_gtset (XXRESID, gt2, fit) + call geo_gtset (XYRESID, gt3, fit) + call geo_gtset (YXRESID, gt4, fit) + call geo_gtset (YYRESID, gt5, fit) + + # Make the first plot. + call gclear (gd) + call geo_label (FIT, gt1, fit) + call geo_1graphr (gd, gt1, fit, gfit, xref, yref, xin, yin, wts, + npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyr (gd, fit, sx1, sy1, sx2, sy2) + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + + # Read the cursor commands. + call amovr (wts, Memr[w], npts) + while (clgcur ("cursor", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != EOF) { + + switch (key) { + + case 'q': + call amovr (Memr[w], wts, npts) + break + + case '?': + if (GM_PROJECTION(fit) == GM_NONE) + call gpagefile (gd, GHELPFILE, "") + else + call gpagefile (gd, CHELPFILE, "") + + case ':': + call geo_colon (gd, fit, gfit, Memc[cmd], newgraph) + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call gt_colon (Memc[cmd], gd, gt1, newgraph) + case XXRESID: + call gt_colon (Memc[cmd], gd, gt2, newgraph) + case XYRESID: + call gt_colon (Memc[cmd], gd, gt3, newgraph) + case YXRESID: + call gt_colon (Memc[cmd], gd, gt4, newgraph) + case YYRESID: + call gt_colon (Memc[cmd], gd, gt5, newgraph) + } + + case 'l': + if (GG_FITERROR(gfit) == NO) { + call geo_lcoeffr (sx1, sy1, xshift, yshift, xscale, yscale, + thetax, thetay) + call printf ("xshift: %.2f yshift: %.2f ") + call pargr (xshift) + call pargr (yshift) + call printf ("xmag: %0.3g ymag: %0.3g ") + call pargr (xscale) + call pargr (yscale) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargr (thetax) + call pargr (thetay) + } + + case 't': + if (GG_FITERROR(gfit) == NO && GG_PLOTTYPE(gfit) == FIT) + call geo_lxyr (gd, fit, sx1, sy1, sx2, sy2, xref, yref, + xin, yin, npts, wx, wy) + + case 'c': + if (GG_CONSTXY(gfit) == YES) + GG_CONSTXY(gfit) = NO + else if (GG_CONSTXY(gfit) == NO) + GG_CONSTXY(gfit) = YES + + case 'd', 'u': + if (key == 'd') + delete = YES + else + delete = NO + + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_1deleter (gd, xin, yin, Memr[w], wts, npts, wx, + wy, delete) + case XXRESID: + call geo_2deleter (gd, xref, Memr[xresid], Memr[w], wts, + npts, wx, wy, delete) + case XYRESID: + call geo_2deleter (gd, yref, Memr[xresid], Memr[w], wts, + npts, wx, wy, delete) + case YXRESID: + call geo_2deleter (gd, xref, Memr[yresid], Memr[w], wts, + npts, wx, wy, delete) + case YYRESID: + call geo_2deleter (gd, yref, Memr[yresid], Memr[w], wts, + npts, wx, wy, delete) + } + + GG_NEWFUNCTION(gfit) = YES + + case 'g': + if (GG_PLOTTYPE(gfit) != FIT) + newgraph = YES + GG_PLOTTYPE(gfit) = FIT + + case 'x': + if (GG_PLOTTYPE(gfit) != XXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XXRESID + + case 'r': + if (GG_PLOTTYPE(gfit) != XYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XYRESID + + case 'y': + if (GG_PLOTTYPE(gfit) != YXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YXRESID + + case 's': + if (GG_PLOTTYPE(gfit) != YYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YYRESID + + case 'f': + # do fit + if (GG_NEWFUNCTION(gfit) == YES) { + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, + Memr[w], Memr[xresid], npts, YES, + xerrmsg, maxch) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, + Memr[w], Memr[yresid], npts, NO, + yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, + yref, xin, yin, Memr[w], Memr[xresid], + Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + } then { + errcode = errget (errstr, SZ_LINE) + call printf ("%s\n") + call pargstr (errstr) + GG_FITERROR(gfit) = YES + } + } + + # plot new graph + if (GG_FITERROR(gfit) == YES) + newgraph = NO + else + newgraph = YES + + case 'o': + GG_OVERPLOT(gfit) = YES + + default: + call printf ("\07") + + } + + if (newgraph == YES) { + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_label (FIT, gt1, fit) + call geo_1graphr (gd, gt1, fit, gfit, xref, yref, xin, yin, + Memr[w], npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyr (gd, fit, sx1, sy1, sx2, sy2) + case XXRESID: + call geo_label (XXRESID, gt2, fit) + call geo_2graphr (gd, gt2, fit, gfit, xref, Memr[xresid], + Memr[w], npts) + case XYRESID: + call geo_label (XYRESID, gt3, fit) + call geo_2graphr (gd, gt3, fit, gfit, yref, Memr[xresid], + Memr[w], npts) + case YXRESID: + call geo_label (YXRESID, gt4, fit) + call geo_2graphr (gd, gt4, fit, gfit, xref, Memr[yresid], + Memr[w], npts) + case YYRESID: + call geo_label (YYRESID, gt5, fit) + call geo_2graphr (gd, gt5, fit, gfit, yref, Memr[yresid], + Memr[w], npts) + } + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + newgraph = NO + } + } + + # Free space. + call gt_free (gt1) + call gt_free (gt2) + call gt_free (gt3) + call gt_free (gt4) + call gt_free (gt5) + call sfree (sp) + + # Call an error if appropriate. + if (errcode > 0) + call error (2, errstr) +end + +# GEO_LCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, xexpansion, yexpansion, x and y rotations. + +procedure geo_lcoeffr (sx, sy, xshift, yshift, xscale, yscale, xrot, yrot) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +real xshift #O output x shift +real yshift #O output y shift +real xscale #O output x scale +real yscale #O output y scale +real xrot #O rotation of point on x axis +real yrot #O rotation of point on y axis + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +real xxrange, xyrange, xxmaxmin, xymaxmin +real yxrange, yyrange, yxmaxmin, yymaxmin +real a, b, c, d + +bool fp_equalr() +int gsgeti() +real gsgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, gsgeti (sx, GSNCOEFF), TY_REAL) + call salloc (ycoeff, gsgeti (sy, GSNCOEFF), TY_REAL) + + # Get coefficients and numbers of coefficients. + call gscoeff (sx, Memr[xcoeff], nxxcoeff) + call gscoeff (sy, Memr[ycoeff], nyycoeff) + nxxcoeff = gsgeti (sx, GSNXCOEFF) + nxycoeff = gsgeti (sx, GSNYCOEFF) + nyxcoeff = gsgeti (sy, GSNXCOEFF) + nyycoeff = gsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (gsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (gsgetr (sx, GSXMAX) - gsgetr (sx, GSXMIN)) / 2.0 + xxmaxmin = - (gsgetr (sx, GSXMAX) + gsgetr (sx, GSXMIN)) / 2.0 + xyrange = (gsgetr (sx, GSYMAX) - gsgetr (sx, GSYMIN)) / 2.0 + xymaxmin = - (gsgetr (sx, GSYMAX) + gsgetr (sx, GSYMIN)) / 2.0 + } else { + xxrange = real(1.0) + xxmaxmin = real(0.0) + xyrange = real(1.0) + xymaxmin = real(0.0) + } + + if (gsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (gsgetr (sy, GSXMAX) - gsgetr (sy, GSXMIN)) / 2.0 + yxmaxmin = - (gsgetr (sy, GSXMAX) + gsgetr (sy, GSXMIN)) / 2.0 + yyrange = (gsgetr (sy, GSYMAX) - gsgetr (sy, GSYMIN)) / 2.0 + yymaxmin = - (gsgetr (sy, GSYMAX) + gsgetr (sy, GSYMIN)) / 2.0 + } else { + yxrange = real(1.0) + yxmaxmin = real(0.0) + yyrange = real(1.0) + yymaxmin = real(0.0) + } + + # Get the shifts. + xshift = Memr[xcoeff] + Memr[xcoeff+1] * xxmaxmin / xxrange + + Memr[xcoeff+2] * xymaxmin / xyrange + yshift = Memr[ycoeff] + Memr[ycoeff+1] * yxmaxmin / yxrange + + Memr[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memr[xcoeff+1] / xxrange + else + a = real(0.0) + if (nxycoeff > 1) + b = Memr[xcoeff+nxxcoeff] / xyrange + else + b = real(0.0) + if (nyxcoeff > 1) + c = Memr[ycoeff+1] / yxrange + else + c = real(0.0) + if (nyycoeff > 1) + d = Memr[ycoeff+nyxcoeff] / yyrange + else + d = real(0.0) + + # Get the magnification factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equalr (a, real(0.0)) && fp_equalr (c, real(0.0))) + xrot = real(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < real(0.0)) + xrot = xrot + real(360.0) + + if (fp_equalr (b, real(0.0)) && fp_equalr (d, real(0.0))) + yrot = real(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < real(0.0)) + yrot = yrot + real(360.0) + + call sfree (sp) +end + + + +# GEO_MGFIT -- Fit the surface using interactive graphics. + +procedure geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, npts, xerrmsg, yerrmsg, maxch) + +pointer gd #I graphics file descriptor +pointer fit #I pointer to the fit structure +pointer sx1 #I pointer to the linear x surface fit +pointer sy1 #I pointer to the linear y surface fit +pointer sx2 #I pointer to higher order x surface fit +pointer sy2 #I pointer to higher order y surface fit +double xref[npts] #I the x reference coordinates +double yref[npts] #I the y reference coordinates +double xin[npts] #I input x coordinates +double yin[npts] #I input y coordinates +double wts[npts] #I array of weights +int npts #I number of data points +char xerrmsg[ARB] #O the output x fit error message +char yerrmsg[ARB] #O the output x fit error message +int maxch #I the size of the error messages + +char errstr[SZ_LINE] +int newgraph, delete, wcs, key, errcode +pointer sp, w, gfit, xresid, yresid, cmd +pointer gt1, gt2, gt3, gt4, gt5 +real wx, wy +double xshift, yshift, xscale, yscale, thetax, thetay + +int clgcur(), errget() +pointer gt_init() + +errchk geo_fxyd(), geo_mrejectd(), geo_fthetad() +errchk geo_fmagnifyd(), geo_flineard() + +begin + # Initialize gfit structure and working space. + call smark (sp) + call salloc (gfit, LEN_GEOGRAPH, TY_STRUCT) + call salloc (xresid, npts, TY_DOUBLE) + call salloc (yresid, npts, TY_DOUBLE) + call salloc (w, npts, TY_DOUBLE) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Do initial fit. + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, wts, + Memd[xresid], npts, YES, xerrmsg, maxch) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, wts, + Memd[yresid], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, Memd[xresid], Memd[yresid], npts, xerrmsg, + maxch, yerrmsg, maxch) + } then { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) + call error (2, "Too few points for X and Y fits.") + else + call error (2, "Too few points for XI and ETA fits.") + } + + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + + # Set up plotting defaults. + GG_PLOTTYPE(gfit) = FIT + GG_OVERPLOT(gfit) = NO + GG_CONSTXY(gfit) = YES + newgraph = NO + + # Allocate graphics tools. + gt1 = gt_init () + gt2 = gt_init () + gt3 = gt_init () + gt4 = gt_init () + gt5 = gt_init () + + # Set the plot title and x and y axis labels. + call geo_gtset (FIT, gt1, fit) + call geo_gtset (XXRESID, gt2, fit) + call geo_gtset (XYRESID, gt3, fit) + call geo_gtset (YXRESID, gt4, fit) + call geo_gtset (YYRESID, gt5, fit) + + # Make the first plot. + call gclear (gd) + call geo_label (FIT, gt1, fit) + call geo_1graphd (gd, gt1, fit, gfit, xref, yref, xin, yin, wts, + npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyd (gd, fit, sx1, sy1, sx2, sy2) + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + + # Read the cursor commands. + call amovd (wts, Memd[w], npts) + while (clgcur ("cursor", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != EOF) { + + switch (key) { + + case 'q': + call amovd (Memd[w], wts, npts) + break + + case '?': + if (GM_PROJECTION(fit) == GM_NONE) + call gpagefile (gd, GHELPFILE, "") + else + call gpagefile (gd, CHELPFILE, "") + + case ':': + call geo_colon (gd, fit, gfit, Memc[cmd], newgraph) + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call gt_colon (Memc[cmd], gd, gt1, newgraph) + case XXRESID: + call gt_colon (Memc[cmd], gd, gt2, newgraph) + case XYRESID: + call gt_colon (Memc[cmd], gd, gt3, newgraph) + case YXRESID: + call gt_colon (Memc[cmd], gd, gt4, newgraph) + case YYRESID: + call gt_colon (Memc[cmd], gd, gt5, newgraph) + } + + case 'l': + if (GG_FITERROR(gfit) == NO) { + call geo_lcoeffd (sx1, sy1, xshift, yshift, xscale, yscale, + thetax, thetay) + call printf ("xshift: %.2f yshift: %.2f ") + call pargd (xshift) + call pargd (yshift) + call printf ("xmag: %0.3g ymag: %0.3g ") + call pargd (xscale) + call pargd (yscale) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargd (thetax) + call pargd (thetay) + } + + case 't': + if (GG_FITERROR(gfit) == NO && GG_PLOTTYPE(gfit) == FIT) + call geo_lxyd (gd, fit, sx1, sy1, sx2, sy2, xref, yref, + xin, yin, npts, wx, wy) + + case 'c': + if (GG_CONSTXY(gfit) == YES) + GG_CONSTXY(gfit) = NO + else if (GG_CONSTXY(gfit) == NO) + GG_CONSTXY(gfit) = YES + + case 'd', 'u': + if (key == 'd') + delete = YES + else + delete = NO + + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_1deleted (gd, xin, yin, Memd[w], wts, npts, wx, + wy, delete) + case XXRESID: + call geo_2deleted (gd, xref, Memd[xresid], Memd[w], wts, + npts, wx, wy, delete) + case XYRESID: + call geo_2deleted (gd, yref, Memd[xresid], Memd[w], wts, + npts, wx, wy, delete) + case YXRESID: + call geo_2deleted (gd, xref, Memd[yresid], Memd[w], wts, + npts, wx, wy, delete) + case YYRESID: + call geo_2deleted (gd, yref, Memd[yresid], Memd[w], wts, + npts, wx, wy, delete) + } + + GG_NEWFUNCTION(gfit) = YES + + case 'g': + if (GG_PLOTTYPE(gfit) != FIT) + newgraph = YES + GG_PLOTTYPE(gfit) = FIT + + case 'x': + if (GG_PLOTTYPE(gfit) != XXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XXRESID + + case 'r': + if (GG_PLOTTYPE(gfit) != XYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XYRESID + + case 'y': + if (GG_PLOTTYPE(gfit) != YXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YXRESID + + case 's': + if (GG_PLOTTYPE(gfit) != YYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YYRESID + + case 'f': + # do fit + if (GG_NEWFUNCTION(gfit) == YES) { + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, + Memd[w], Memd[xresid], npts, YES, + xerrmsg, maxch) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, + Memd[w], Memd[yresid], npts, NO, + yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, + yref, xin, yin, Memd[w], Memd[xresid], + Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + } then { + errcode = errget (errstr, SZ_LINE) + call printf ("%s\n") + call pargstr (errstr) + GG_FITERROR(gfit) = YES + } + } + + # plot new graph + if (GG_FITERROR(gfit) == YES) + newgraph = NO + else + newgraph = YES + + case 'o': + GG_OVERPLOT(gfit) = YES + + default: + call printf ("\07") + + } + + if (newgraph == YES) { + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_label (FIT, gt1, fit) + call geo_1graphd (gd, gt1, fit, gfit, xref, yref, xin, yin, + Memd[w], npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyd (gd, fit, sx1, sy1, sx2, sy2) + case XXRESID: + call geo_label (XXRESID, gt2, fit) + call geo_2graphd (gd, gt2, fit, gfit, xref, Memd[xresid], + Memd[w], npts) + case XYRESID: + call geo_label (XYRESID, gt3, fit) + call geo_2graphd (gd, gt3, fit, gfit, yref, Memd[xresid], + Memd[w], npts) + case YXRESID: + call geo_label (YXRESID, gt4, fit) + call geo_2graphd (gd, gt4, fit, gfit, xref, Memd[yresid], + Memd[w], npts) + case YYRESID: + call geo_label (YYRESID, gt5, fit) + call geo_2graphd (gd, gt5, fit, gfit, yref, Memd[yresid], + Memd[w], npts) + } + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + newgraph = NO + } + } + + # Free space. + call gt_free (gt1) + call gt_free (gt2) + call gt_free (gt3) + call gt_free (gt4) + call gt_free (gt5) + call sfree (sp) + + # Call an error if appropriate. + if (errcode > 0) + call error (2, errstr) +end + +# GEO_LCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, xexpansion, yexpansion, x and y rotations. + +procedure geo_lcoeffd (sx, sy, xshift, yshift, xscale, yscale, xrot, yrot) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +double xshift #O output x shift +double yshift #O output y shift +double xscale #O output x scale +double yscale #O output y scale +double xrot #O rotation of point on x axis +double yrot #O rotation of point on y axis + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +double xxrange, xyrange, xxmaxmin, xymaxmin +double yxrange, yyrange, yxmaxmin, yymaxmin +double a, b, c, d + +bool fp_equald() +int dgsgeti() +double dgsgetd() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_DOUBLE) + call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_DOUBLE) + + # Get coefficients and numbers of coefficients. + call dgscoeff (sx, Memd[xcoeff], nxxcoeff) + call dgscoeff (sy, Memd[ycoeff], nyycoeff) + nxxcoeff = dgsgeti (sx, GSNXCOEFF) + nxycoeff = dgsgeti (sx, GSNYCOEFF) + nyxcoeff = dgsgeti (sy, GSNXCOEFF) + nyycoeff = dgsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 + xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 + xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 + xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 + } else { + xxrange = double(1.0) + xxmaxmin = double(0.0) + xyrange = double(1.0) + xymaxmin = double(0.0) + } + + if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 + yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 + yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 + yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 + } else { + yxrange = double(1.0) + yxmaxmin = double(0.0) + yyrange = double(1.0) + yymaxmin = double(0.0) + } + + # Get the shifts. + xshift = Memd[xcoeff] + Memd[xcoeff+1] * xxmaxmin / xxrange + + Memd[xcoeff+2] * xymaxmin / xyrange + yshift = Memd[ycoeff] + Memd[ycoeff+1] * yxmaxmin / yxrange + + Memd[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memd[xcoeff+1] / xxrange + else + a = double(0.0) + if (nxycoeff > 1) + b = Memd[xcoeff+nxxcoeff] / xyrange + else + b = double(0.0) + if (nyxcoeff > 1) + c = Memd[ycoeff+1] / yxrange + else + c = double(0.0) + if (nyycoeff > 1) + d = Memd[ycoeff+nyxcoeff] / yyrange + else + d = double(0.0) + + # Get the magnification factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equald (a, double(0.0)) && fp_equald (c, double(0.0))) + xrot = double(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < double(0.0)) + xrot = xrot + double(360.0) + + if (fp_equald (b, double(0.0)) && fp_equald (d, double(0.0))) + yrot = double(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < double(0.0)) + yrot = yrot + double(360.0) + + call sfree (sp) +end + + diff --git a/pkg/images/lib/geogmapi.x b/pkg/images/lib/geogmapi.x new file mode 100644 index 00000000..9dc63610 --- /dev/null +++ b/pkg/images/lib/geogmapi.x @@ -0,0 +1,905 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "geomap.h" +include "geogmap.h" + +define GHELPFILE "images$lib/geomap.key" +define CHELPFILE "images$lib/coomap.key" + + + +# GEO_MGFIT -- Fit the surface using interactive graphics. + +procedure geo_mgfitr (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, npts, xerrmsg, yerrmsg, maxch) + +pointer gd #I graphics file descriptor +pointer fit #I pointer to the fit structure +pointer sx1 #I pointer to the linear x surface fit +pointer sy1 #I pointer to the linear y surface fit +pointer sx2 #I pointer to higher order x surface fit +pointer sy2 #I pointer to higher order y surface fit +real xref[npts] #I the x reference coordinates +real yref[npts] #I the y reference coordinates +real xin[npts] #I input x coordinates +real yin[npts] #I input y coordinates +real wts[npts] #I array of weights +int npts #I number of data points +char xerrmsg[ARB] #O the output x fit error message +char yerrmsg[ARB] #O the output x fit error message +int maxch #I the size of the error messages + +char errstr[SZ_LINE] +int newgraph, delete, wcs, key, errcode +pointer sp, w, gfit, xresid, yresid, cmd +pointer gt1, gt2, gt3, gt4, gt5 +real wx, wy +real xshift, yshift, xscale, yscale, thetax, thetay + +int clgcur(), errget() +pointer gt_init() + +errchk geo_fxyr(), geo_mrejectr(), geo_fthetar() +errchk geo_fmagnifyr(), geo_flinearr() + +begin + # Initialize gfit structure and working space. + call smark (sp) + call salloc (gfit, LEN_GEOGRAPH, TY_STRUCT) + call salloc (xresid, npts, TY_REAL) + call salloc (yresid, npts, TY_REAL) + call salloc (w, npts, TY_REAL) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Do initial fit. + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memr[xresid], Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, wts, + Memr[xresid], npts, YES, xerrmsg, maxch) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, wts, + Memr[yresid], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, Memr[xresid], Memr[yresid], npts, xerrmsg, + maxch, yerrmsg, maxch) + } then { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) + call error (2, "Too few points for X and Y fits.") + else + call error (2, "Too few points for XI and ETA fits.") + } + + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + + # Set up plotting defaults. + GG_PLOTTYPE(gfit) = FIT + GG_OVERPLOT(gfit) = NO + GG_CONSTXY(gfit) = YES + newgraph = NO + + # Allocate graphics tools. + gt1 = gt_init () + gt2 = gt_init () + gt3 = gt_init () + gt4 = gt_init () + gt5 = gt_init () + + # Set the plot title and x and y axis labels. + call geo_gtset (FIT, gt1, fit) + call geo_gtset (XXRESID, gt2, fit) + call geo_gtset (XYRESID, gt3, fit) + call geo_gtset (YXRESID, gt4, fit) + call geo_gtset (YYRESID, gt5, fit) + + # Make the first plot. + call gclear (gd) + call geo_label (FIT, gt1, fit) + call geo_1graphr (gd, gt1, fit, gfit, xref, yref, xin, yin, wts, + npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyr (gd, fit, sx1, sy1, sx2, sy2) + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + + # Read the cursor commands. + call amovr (wts, Memr[w], npts) + while (clgcur ("cursor", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != EOF) { + + switch (key) { + + case 'q': + call amovr (Memr[w], wts, npts) + break + + case '?': + if (GM_PROJECTION(fit) == GM_NONE) + call gpagefile (gd, GHELPFILE, "") + else + call gpagefile (gd, CHELPFILE, "") + + case ':': + call geo_colon (gd, fit, gfit, Memc[cmd], newgraph) + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call gt_colon (Memc[cmd], gd, gt1, newgraph) + case XXRESID: + call gt_colon (Memc[cmd], gd, gt2, newgraph) + case XYRESID: + call gt_colon (Memc[cmd], gd, gt3, newgraph) + case YXRESID: + call gt_colon (Memc[cmd], gd, gt4, newgraph) + case YYRESID: + call gt_colon (Memc[cmd], gd, gt5, newgraph) + } + + case 'l': + if (GG_FITERROR(gfit) == NO) { + call geo_lcoeffr (sx1, sy1, xshift, yshift, xscale, yscale, + thetax, thetay) + call printf ("xshift: %.2f yshift: %.2f ") + call pargr (xshift) + call pargr (yshift) + call printf ("xmag: %0.3g ymag: %0.3g ") + call pargr (xscale) + call pargr (yscale) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargr (thetax) + call pargr (thetay) + } + + case 't': + if (GG_FITERROR(gfit) == NO && GG_PLOTTYPE(gfit) == FIT) + call geo_lxyr (gd, fit, sx1, sy1, sx2, sy2, xref, yref, + xin, yin, npts, wx, wy) + + case 'c': + if (GG_CONSTXY(gfit) == YES) + GG_CONSTXY(gfit) = NO + else if (GG_CONSTXY(gfit) == NO) + GG_CONSTXY(gfit) = YES + + case 'd', 'u': + if (key == 'd') + delete = YES + else + delete = NO + + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_1deleter (gd, xin, yin, Memr[w], wts, npts, wx, + wy, delete) + case XXRESID: + call geo_2deleter (gd, xref, Memr[xresid], Memr[w], wts, + npts, wx, wy, delete) + case XYRESID: + call geo_2deleter (gd, yref, Memr[xresid], Memr[w], wts, + npts, wx, wy, delete) + case YXRESID: + call geo_2deleter (gd, xref, Memr[yresid], Memr[w], wts, + npts, wx, wy, delete) + case YYRESID: + call geo_2deleter (gd, yref, Memr[yresid], Memr[w], wts, + npts, wx, wy, delete) + } + + GG_NEWFUNCTION(gfit) = YES + + case 'g': + if (GG_PLOTTYPE(gfit) != FIT) + newgraph = YES + GG_PLOTTYPE(gfit) = FIT + + case 'x': + if (GG_PLOTTYPE(gfit) != XXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XXRESID + + case 'r': + if (GG_PLOTTYPE(gfit) != XYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XYRESID + + case 'y': + if (GG_PLOTTYPE(gfit) != YXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YXRESID + + case 's': + if (GG_PLOTTYPE(gfit) != YYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YYRESID + + case 'f': + # do fit + if (GG_NEWFUNCTION(gfit) == YES) { + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetar (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyr (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flinearr (fit, sx1, sy1, xref, yref, xin, + yin, Memr[w], Memr[xresid], Memr[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyr (fit, sx1, sx2, xref, yref, xin, + Memr[w], Memr[xresid], npts, YES, + xerrmsg, maxch) + call geo_fxyr (fit, sy1, sy2, xref, yref, yin, + Memr[w], Memr[yresid], npts, NO, + yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectr (fit, sx1, sy1, sx2, sy2, xref, + yref, xin, yin, Memr[w], Memr[xresid], + Memr[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + } then { + errcode = errget (errstr, SZ_LINE) + call printf ("%s\n") + call pargstr (errstr) + GG_FITERROR(gfit) = YES + } + } + + # plot new graph + if (GG_FITERROR(gfit) == YES) + newgraph = NO + else + newgraph = YES + + case 'o': + GG_OVERPLOT(gfit) = YES + + default: + call printf ("\07") + + } + + if (newgraph == YES) { + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_label (FIT, gt1, fit) + call geo_1graphr (gd, gt1, fit, gfit, xref, yref, xin, yin, + Memr[w], npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyr (gd, fit, sx1, sy1, sx2, sy2) + case XXRESID: + call geo_label (XXRESID, gt2, fit) + call geo_2graphr (gd, gt2, fit, gfit, xref, Memr[xresid], + Memr[w], npts) + case XYRESID: + call geo_label (XYRESID, gt3, fit) + call geo_2graphr (gd, gt3, fit, gfit, yref, Memr[xresid], + Memr[w], npts) + case YXRESID: + call geo_label (YXRESID, gt4, fit) + call geo_2graphr (gd, gt4, fit, gfit, xref, Memr[yresid], + Memr[w], npts) + case YYRESID: + call geo_label (YYRESID, gt5, fit) + call geo_2graphr (gd, gt5, fit, gfit, yref, Memr[yresid], + Memr[w], npts) + } + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + newgraph = NO + } + } + + # Free space. + call gt_free (gt1) + call gt_free (gt2) + call gt_free (gt3) + call gt_free (gt4) + call gt_free (gt5) + call sfree (sp) + + # Call an error if appropriate. + if (errcode > 0) + call error (2, errstr) +end + +# GEO_LCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, xexpansion, yexpansion, x and y rotations. + +procedure geo_lcoeffr (sx, sy, xshift, yshift, xscale, yscale, xrot, yrot) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +real xshift #O output x shift +real yshift #O output y shift +real xscale #O output x scale +real yscale #O output y scale +real xrot #O rotation of point on x axis +real yrot #O rotation of point on y axis + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +real xxrange, xyrange, xxmaxmin, xymaxmin +real yxrange, yyrange, yxmaxmin, yymaxmin +real a, b, c, d + +bool fp_equalr() +int gsgeti() +real gsgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, gsgeti (sx, GSNCOEFF), TY_REAL) + call salloc (ycoeff, gsgeti (sy, GSNCOEFF), TY_REAL) + + # Get coefficients and numbers of coefficients. + call gscoeff (sx, Memr[xcoeff], nxxcoeff) + call gscoeff (sy, Memr[ycoeff], nyycoeff) + nxxcoeff = gsgeti (sx, GSNXCOEFF) + nxycoeff = gsgeti (sx, GSNYCOEFF) + nyxcoeff = gsgeti (sy, GSNXCOEFF) + nyycoeff = gsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (gsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (gsgetr (sx, GSXMAX) - gsgetr (sx, GSXMIN)) / 2.0 + xxmaxmin = - (gsgetr (sx, GSXMAX) + gsgetr (sx, GSXMIN)) / 2.0 + xyrange = (gsgetr (sx, GSYMAX) - gsgetr (sx, GSYMIN)) / 2.0 + xymaxmin = - (gsgetr (sx, GSYMAX) + gsgetr (sx, GSYMIN)) / 2.0 + } else { + xxrange = real(1.0) + xxmaxmin = real(0.0) + xyrange = real(1.0) + xymaxmin = real(0.0) + } + + if (gsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (gsgetr (sy, GSXMAX) - gsgetr (sy, GSXMIN)) / 2.0 + yxmaxmin = - (gsgetr (sy, GSXMAX) + gsgetr (sy, GSXMIN)) / 2.0 + yyrange = (gsgetr (sy, GSYMAX) - gsgetr (sy, GSYMIN)) / 2.0 + yymaxmin = - (gsgetr (sy, GSYMAX) + gsgetr (sy, GSYMIN)) / 2.0 + } else { + yxrange = real(1.0) + yxmaxmin = real(0.0) + yyrange = real(1.0) + yymaxmin = real(0.0) + } + + # Get the shifts. + xshift = Memr[xcoeff] + Memr[xcoeff+1] * xxmaxmin / xxrange + + Memr[xcoeff+2] * xymaxmin / xyrange + yshift = Memr[ycoeff] + Memr[ycoeff+1] * yxmaxmin / yxrange + + Memr[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memr[xcoeff+1] / xxrange + else + a = real(0.0) + if (nxycoeff > 1) + b = Memr[xcoeff+nxxcoeff] / xyrange + else + b = real(0.0) + if (nyxcoeff > 1) + c = Memr[ycoeff+1] / yxrange + else + c = real(0.0) + if (nyycoeff > 1) + d = Memr[ycoeff+nyxcoeff] / yyrange + else + d = real(0.0) + + # Get the magnification factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equalr (a, real(0.0)) && fp_equalr (c, real(0.0))) + xrot = real(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < real(0.0)) + xrot = xrot + real(360.0) + + if (fp_equalr (b, real(0.0)) && fp_equalr (d, real(0.0))) + yrot = real(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < real(0.0)) + yrot = yrot + real(360.0) + + call sfree (sp) +end + + + +# GEO_MGFIT -- Fit the surface using interactive graphics. + +procedure geo_mgfitd (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, npts, xerrmsg, yerrmsg, maxch) + +pointer gd #I graphics file descriptor +pointer fit #I pointer to the fit structure +pointer sx1 #I pointer to the linear x surface fit +pointer sy1 #I pointer to the linear y surface fit +pointer sx2 #I pointer to higher order x surface fit +pointer sy2 #I pointer to higher order y surface fit +double xref[npts] #I the x reference coordinates +double yref[npts] #I the y reference coordinates +double xin[npts] #I input x coordinates +double yin[npts] #I input y coordinates +double wts[npts] #I array of weights +int npts #I number of data points +char xerrmsg[ARB] #O the output x fit error message +char yerrmsg[ARB] #O the output x fit error message +int maxch #I the size of the error messages + +char errstr[SZ_LINE] +int newgraph, delete, wcs, key, errcode +pointer sp, w, gfit, xresid, yresid, cmd +pointer gt1, gt2, gt3, gt4, gt5 +real wx, wy +double xshift, yshift, xscale, yscale, thetax, thetay + +int clgcur(), errget() +pointer gt_init() + +errchk geo_fxyd(), geo_mrejectd(), geo_fthetad() +errchk geo_fmagnifyd(), geo_flineard() + +begin + # Initialize gfit structure and working space. + call smark (sp) + call salloc (gfit, LEN_GEOGRAPH, TY_STRUCT) + call salloc (xresid, npts, TY_DOUBLE) + call salloc (yresid, npts, TY_DOUBLE) + call salloc (w, npts, TY_DOUBLE) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Do initial fit. + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, yin, wts, + Memd[xresid], Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, wts, + Memd[xresid], npts, YES, xerrmsg, maxch) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, wts, + Memd[yresid], npts, NO, yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, yref, xin, + yin, wts, Memd[xresid], Memd[yresid], npts, xerrmsg, + maxch, yerrmsg, maxch) + } then { + call sfree (sp) + if (GM_PROJECTION(fit) == GM_NONE) + call error (2, "Too few points for X and Y fits.") + else + call error (2, "Too few points for XI and ETA fits.") + } + + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + + # Set up plotting defaults. + GG_PLOTTYPE(gfit) = FIT + GG_OVERPLOT(gfit) = NO + GG_CONSTXY(gfit) = YES + newgraph = NO + + # Allocate graphics tools. + gt1 = gt_init () + gt2 = gt_init () + gt3 = gt_init () + gt4 = gt_init () + gt5 = gt_init () + + # Set the plot title and x and y axis labels. + call geo_gtset (FIT, gt1, fit) + call geo_gtset (XXRESID, gt2, fit) + call geo_gtset (XYRESID, gt3, fit) + call geo_gtset (YXRESID, gt4, fit) + call geo_gtset (YYRESID, gt5, fit) + + # Make the first plot. + call gclear (gd) + call geo_label (FIT, gt1, fit) + call geo_1graphd (gd, gt1, fit, gfit, xref, yref, xin, yin, wts, + npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyd (gd, fit, sx1, sy1, sx2, sy2) + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + + # Read the cursor commands. + call amovd (wts, Memd[w], npts) + while (clgcur ("cursor", wx, wy, wcs, key, Memc[cmd], SZ_LINE) != EOF) { + + switch (key) { + + case 'q': + call amovd (Memd[w], wts, npts) + break + + case '?': + if (GM_PROJECTION(fit) == GM_NONE) + call gpagefile (gd, GHELPFILE, "") + else + call gpagefile (gd, CHELPFILE, "") + + case ':': + call geo_colon (gd, fit, gfit, Memc[cmd], newgraph) + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call gt_colon (Memc[cmd], gd, gt1, newgraph) + case XXRESID: + call gt_colon (Memc[cmd], gd, gt2, newgraph) + case XYRESID: + call gt_colon (Memc[cmd], gd, gt3, newgraph) + case YXRESID: + call gt_colon (Memc[cmd], gd, gt4, newgraph) + case YYRESID: + call gt_colon (Memc[cmd], gd, gt5, newgraph) + } + + case 'l': + if (GG_FITERROR(gfit) == NO) { + call geo_lcoeffd (sx1, sy1, xshift, yshift, xscale, yscale, + thetax, thetay) + call printf ("xshift: %.2f yshift: %.2f ") + call pargd (xshift) + call pargd (yshift) + call printf ("xmag: %0.3g ymag: %0.3g ") + call pargd (xscale) + call pargd (yscale) + call printf ("xrot: %.2f yrot: %.2f\n") + call pargd (thetax) + call pargd (thetay) + } + + case 't': + if (GG_FITERROR(gfit) == NO && GG_PLOTTYPE(gfit) == FIT) + call geo_lxyd (gd, fit, sx1, sy1, sx2, sy2, xref, yref, + xin, yin, npts, wx, wy) + + case 'c': + if (GG_CONSTXY(gfit) == YES) + GG_CONSTXY(gfit) = NO + else if (GG_CONSTXY(gfit) == NO) + GG_CONSTXY(gfit) = YES + + case 'd', 'u': + if (key == 'd') + delete = YES + else + delete = NO + + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_1deleted (gd, xin, yin, Memd[w], wts, npts, wx, + wy, delete) + case XXRESID: + call geo_2deleted (gd, xref, Memd[xresid], Memd[w], wts, + npts, wx, wy, delete) + case XYRESID: + call geo_2deleted (gd, yref, Memd[xresid], Memd[w], wts, + npts, wx, wy, delete) + case YXRESID: + call geo_2deleted (gd, xref, Memd[yresid], Memd[w], wts, + npts, wx, wy, delete) + case YYRESID: + call geo_2deleted (gd, yref, Memd[yresid], Memd[w], wts, + npts, wx, wy, delete) + } + + GG_NEWFUNCTION(gfit) = YES + + case 'g': + if (GG_PLOTTYPE(gfit) != FIT) + newgraph = YES + GG_PLOTTYPE(gfit) = FIT + + case 'x': + if (GG_PLOTTYPE(gfit) != XXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XXRESID + + case 'r': + if (GG_PLOTTYPE(gfit) != XYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = XYRESID + + case 'y': + if (GG_PLOTTYPE(gfit) != YXRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YXRESID + + case 's': + if (GG_PLOTTYPE(gfit) != YYRESID) + newgraph = YES + GG_PLOTTYPE(gfit) = YYRESID + + case 'f': + # do fit + if (GG_NEWFUNCTION(gfit) == YES) { + iferr { + switch (GM_FIT(fit)) { + case GM_ROTATE: + call geo_fthetad (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RSCALE: + call geo_fmagnifyd (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + case GM_RXYSCALE: + call geo_flineard (fit, sx1, sy1, xref, yref, xin, + yin, Memd[w], Memd[xresid], Memd[yresid], + npts, xerrmsg, maxch, yerrmsg, maxch) + sx2 = NULL + sy2 = NULL + default: + call geo_fxyd (fit, sx1, sx2, xref, yref, xin, + Memd[w], Memd[xresid], npts, YES, + xerrmsg, maxch) + call geo_fxyd (fit, sy1, sy2, xref, yref, yin, + Memd[w], Memd[yresid], npts, NO, + yerrmsg, maxch) + } + if (GM_MAXITER(fit) <= 0 || IS_INDEFD(GM_REJECT(fit))) + GM_NREJECT(fit) = 0 + else + call geo_mrejectd (fit, sx1, sy1, sx2, sy2, xref, + yref, xin, yin, Memd[w], Memd[xresid], + Memd[yresid], npts, xerrmsg, maxch, + yerrmsg, maxch) + GG_NEWFUNCTION(gfit) = NO + GG_FITERROR(gfit) = NO + errcode = OK + } then { + errcode = errget (errstr, SZ_LINE) + call printf ("%s\n") + call pargstr (errstr) + GG_FITERROR(gfit) = YES + } + } + + # plot new graph + if (GG_FITERROR(gfit) == YES) + newgraph = NO + else + newgraph = YES + + case 'o': + GG_OVERPLOT(gfit) = YES + + default: + call printf ("\07") + + } + + if (newgraph == YES) { + switch (GG_PLOTTYPE(gfit)) { + case FIT: + call geo_label (FIT, gt1, fit) + call geo_1graphd (gd, gt1, fit, gfit, xref, yref, xin, yin, + Memd[w], npts) + if (GG_CONSTXY(gfit) == YES) + call geo_conxyd (gd, fit, sx1, sy1, sx2, sy2) + case XXRESID: + call geo_label (XXRESID, gt2, fit) + call geo_2graphd (gd, gt2, fit, gfit, xref, Memd[xresid], + Memd[w], npts) + case XYRESID: + call geo_label (XYRESID, gt3, fit) + call geo_2graphd (gd, gt3, fit, gfit, yref, Memd[xresid], + Memd[w], npts) + case YXRESID: + call geo_label (YXRESID, gt4, fit) + call geo_2graphd (gd, gt4, fit, gfit, xref, Memd[yresid], + Memd[w], npts) + case YYRESID: + call geo_label (YYRESID, gt5, fit) + call geo_2graphd (gd, gt5, fit, gfit, yref, Memd[yresid], + Memd[w], npts) + } + call printf ("%s %s\n") + call pargstr (xerrmsg) + call pargstr (yerrmsg) + newgraph = NO + } + } + + # Free space. + call gt_free (gt1) + call gt_free (gt2) + call gt_free (gt3) + call gt_free (gt4) + call gt_free (gt5) + call sfree (sp) + + # Call an error if appropriate. + if (errcode > 0) + call error (2, errstr) +end + +# GEO_LCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, xexpansion, yexpansion, x and y rotations. + +procedure geo_lcoeffd (sx, sy, xshift, yshift, xscale, yscale, xrot, yrot) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +double xshift #O output x shift +double yshift #O output y shift +double xscale #O output x scale +double yscale #O output y scale +double xrot #O rotation of point on x axis +double yrot #O rotation of point on y axis + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +double xxrange, xyrange, xxmaxmin, xymaxmin +double yxrange, yyrange, yxmaxmin, yymaxmin +double a, b, c, d + +bool fp_equald() +int dgsgeti() +double dgsgetd() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_DOUBLE) + call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_DOUBLE) + + # Get coefficients and numbers of coefficients. + call dgscoeff (sx, Memd[xcoeff], nxxcoeff) + call dgscoeff (sy, Memd[ycoeff], nyycoeff) + nxxcoeff = dgsgeti (sx, GSNXCOEFF) + nxycoeff = dgsgeti (sx, GSNYCOEFF) + nyxcoeff = dgsgeti (sy, GSNXCOEFF) + nyycoeff = dgsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 + xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 + xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 + xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 + } else { + xxrange = double(1.0) + xxmaxmin = double(0.0) + xyrange = double(1.0) + xymaxmin = double(0.0) + } + + if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 + yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 + yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 + yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 + } else { + yxrange = double(1.0) + yxmaxmin = double(0.0) + yyrange = double(1.0) + yymaxmin = double(0.0) + } + + # Get the shifts. + xshift = Memd[xcoeff] + Memd[xcoeff+1] * xxmaxmin / xxrange + + Memd[xcoeff+2] * xymaxmin / xyrange + yshift = Memd[ycoeff] + Memd[ycoeff+1] * yxmaxmin / yxrange + + Memd[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memd[xcoeff+1] / xxrange + else + a = double(0.0) + if (nxycoeff > 1) + b = Memd[xcoeff+nxxcoeff] / xyrange + else + b = double(0.0) + if (nyxcoeff > 1) + c = Memd[ycoeff+1] / yxrange + else + c = double(0.0) + if (nyycoeff > 1) + d = Memd[ycoeff+nyxcoeff] / yyrange + else + d = double(0.0) + + # Get the magnification factors. + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equald (a, double(0.0)) && fp_equald (c, double(0.0))) + xrot = double(0.0) + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < double(0.0)) + xrot = xrot + double(360.0) + + if (fp_equald (b, double(0.0)) && fp_equald (d, double(0.0))) + yrot = double(0.0) + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < double(0.0)) + yrot = yrot + double(360.0) + + call sfree (sp) +end + + diff --git a/pkg/images/lib/geograph.gx b/pkg/images/lib/geograph.gx new file mode 100644 index 00000000..5c42de24 --- /dev/null +++ b/pkg/images/lib/geograph.gx @@ -0,0 +1,1379 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "geomap.h" +include "geogmap.h" + +define MAX_PARAMS (10 * SZ_LINE) +define NINTERVALS 5 +define NGRAPH 100 + +$for (r) + +# GEO_LABEL -- Annotate the plot. + +procedure geo_label (plot_type, gt, fit) + +int plot_type #I type of plot +pointer gt #I gtools descriptor +pointer fit #I geomap fit parameters + +int npts +pointer sp, params, xtermlab, ytermlab +real xrms, yrms, rej +int strlen(), rg_wrdstr() + +begin + call smark (sp) + call salloc (params, MAX_PARAMS, TY_CHAR) + call salloc (xtermlab, SZ_FNAME, TY_CHAR) + call salloc (ytermlab, SZ_FNAME, TY_CHAR) + + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0 + yrms = 0.0 + } + if (IS_INDEFD(GM_REJECT(fit))) + rej = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rej = INDEFR + else + rej = GM_REJECT(fit) + + # Print data parameters. + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params], MAX_PARAMS, + "GEOMAP: function = %s npts = %d reject = %g nrej = %d\n") + else + call sprintf (Memc[params], MAX_PARAMS, + "CCMAP: function = %s npts = %d reject = %g nrej = %d\n") + + switch (GM_FUNCTION(fit)) { + case GS_LEGENDRE: + call pargstr ("legendre") + case GS_CHEBYSHEV: + call pargstr ("chebyshev") + case GS_POLYNOMIAL: + call pargstr ("polynomial") + } + call pargi (GM_NPTS(fit)) + call pargr (rej) + call pargi (GM_NWTS0(fit)) + + # Print fit parameters. + switch (plot_type) { + case FIT: + + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[xtermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[xtermlab], SZ_FNAME) + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[ytermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[ytermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "X fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "XI fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g arcsec\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargstr (Memc[xtermlab]) + call pargr (xrms) + + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "Y fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "ETA fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g arcsec\n") + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + call pargstr (Memc[ytermlab]) + call pargr (yrms) + + case XXRESID, XYRESID: + + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[xtermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[xtermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "X fit: xorder = %d yorder = %d xterms = %s rms = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "XI fit: xorder = %d yorder = %d xterms = %s rms = %8.3g arcsec\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargstr (Memc[xtermlab]) + call pargr (xrms) + + case YXRESID, YYRESID: + + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[ytermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[ytermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "Y fit: xorder = %d yorder = %d xterms = %s rms = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "ETA fit: xorder = %d yorder = %d xterms = %s rms = %8.3g arcsec\n") + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + call pargstr (Memc[ytermlab]) + call pargr (yrms) + + default: + + # do nothing gracefully + } + + call gt_sets (gt, GTPARAMS, Memc[params]) + + call sfree (sp) +end + + +# GEO_GTSET -- Write title and labels. + +procedure geo_gtset (plot_type, gt, fit) + +int plot_type #I plot type +pointer gt #I plot descriptor +pointer fit #I fit descriptor + +char str[SZ_LINE] +int nchars +int gstrcpy() + +begin + nchars = gstrcpy (GM_RECORD(fit), str, SZ_LINE) + + switch (plot_type) { + case FIT: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Coordinate Transformation", str[nchars+1], + SZ_LINE) + else + call strcpy (": Celestial Coordinate Transformation", + str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (in units)") + call gt_sets (gt, GTYLABEL, "Y (in units)") + } else { + call gt_sets (gt, GTXLABEL, "XI (arcsec)") + call gt_sets (gt, GTYLABEL, "ETA (arcsec)") + } + + case XXRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": X fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": XI fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (ref units)") + call gt_sets (gt, GTYLABEL, "X Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "X (pixels)") + call gt_sets (gt, GTYLABEL, "XI Residuals (arcsec)") + } + + case XYRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": X fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": XI fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "Y (ref units)") + call gt_sets (gt, GTYLABEL, "X Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "Y (pixels)") + call gt_sets (gt, GTYLABEL, "XI Residuals (arcsec)") + } + + case YXRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Y fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": ETA fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (ref units)") + call gt_sets (gt, GTYLABEL, "Y (Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "X (pixels)") + call gt_sets (gt, GTYLABEL, "ETA Residuals (arcsec)") + } + + case YYRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Y fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": ETA fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "Y (ref units)") + call gt_sets (gt, GTYLABEL, "Y Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "Y (pixels)") + call gt_sets (gt, GTYLABEL, "ETA Residuals (arcsec)") + } + + default: + + # do nothing gracefully + } +end + + +# GEO_COLON -- Process the colon commands. + +procedure geo_colon (gd, fit, gfit, cmdstr, newgraph) + +pointer gd #I graphics stream +pointer fit #I pointer to fit structure +pointer gfit #I pointer to the gfit structure +char cmdstr[ARB] #I command string +int newgraph #I plot new graph + +int ncmd, ival +pointer sp, str, cmd +real rval +int nscan(), strdic(), rg_wrdstr() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 0) { + call sfree (sp) + return + } + + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_CMDS) + switch (ncmd) { + case GMCMD_SHOW: + call gdeactivate (gd, AW_CLEAR) + call printf ("Current Fitting Parameters\n\n") + if (GM_PROJECTION(fit) != GM_NONE) { + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + ; + call printf ("\tprojection = %s\n") + call pargstr (Memc[str]) + call printf ("\tlngref = %h\n") + call pargd (GM_XREFPT(fit)) + call printf ("\tlatref = %h\n") + call pargd (GM_YREFPT(fit)) + } + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, + GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call printf ("\tfitgeometry = %s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, + GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call printf ("\tfunction = %s\n") + Call pargstr (Memc[str]) + call printf ("\txxorder = %d\n") + call pargi (GM_XXORDER(fit)) + call printf ("\txyorder = %d\n") + call pargi (GM_XYORDER(fit)) + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("\txxterms = %s\n") + call pargstr (Memc[str]) + call printf ("\tyxorder = %d\n") + call pargi (GM_YXORDER(fit)) + call printf ("\tyyorder = %d\n") + call pargi (GM_YYORDER(fit)) + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("\tyxterms = %s\n") + call pargstr (Memc[str]) + if (IS_INDEFD(GM_REJECT(fit))) + rval = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rval = INDEFR + else + rval = GM_REJECT(fit) + call printf ("\treject = %f\n") + call pargr (rval) + call greactivate (gd, AW_PAUSE) + + case GMCMD_PROJECTION: + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + call strcpy ("INDEF", Memc[str], SZ_FNAME) + call printf ("projection = %s\n") + call pargstr (Memc[str]) + + case GMCMD_REFPOINT: + call printf ("lngref = %h latref = %h\n") + call pargd (GM_XREFPT(fit)) + call pargd (GM_YREFPT(fit)) + + case GMCMD_GEOMETRY: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, + GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call printf ("fitgeometry = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_GEOMETRIES) + if (ival > 0) { + GM_FIT(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_FUNCTION: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, + GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call printf ("function = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_FUNCS) + if (ival > 0) { + GM_FUNCTION(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_ORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ( + "xxorder = %d xyorder = %d yxorder = %d yyorder = %d\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + } else { + GM_XXORDER(fit) = max (ival, 2) + GM_XYORDER(fit) = max (ival, 2) + GM_YXORDER(fit) = max (ival, 2) + GM_YYORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XXORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("xxorder = %d\n") + call pargi (GM_XXORDER(fit)) + } else { + GM_XXORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XYORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("xyorder = %d\n") + call pargi (GM_XYORDER(fit)) + } else { + GM_XYORDER(fit) = max (ival,2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_YXORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("yxorder = %d\n") + call pargi (GM_YXORDER(fit)) + } else { + GM_YXORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_YYORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("yyorder = %d\n") + call pargi (GM_YYORDER(fit)) + } else { + GM_YYORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XXTERMS: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("xxterms = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_XFUNCS) + if (ival > 0) { + GM_XXTERMS(fit) = ival - 1 + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_YXTERMS: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("yxterms = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_XFUNCS) + if (ival > 0) { + GM_YXTERMS(fit) = ival - 1 + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_REJECT: + call gargr (rval) + if (nscan() == 1) { + if (IS_INDEFD(GM_REJECT(fit))) + rval = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rval = INDEFR + else + rval = GM_REJECT(fit) + call printf ("reject = %f\n") + call pargr (rval) + } else { + GM_REJECT(fit) = rval + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_MAXITER: + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (GM_MAXITER(fit)) + } else { + GM_MAXITER(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + } + + call sfree (sp) +end + +$endfor + + +$for (rd) + +# GEO_1DELETE -- Delete a point from the fit. + +procedure geo_1delete$t (gd, xin, yin, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +PIXEL xin[ARB] #I x array +PIXEL yin[ARB] #I y array +PIXEL wts[ARB] #I array of weights +PIXEL userwts[ARB] #I array of user weights +int npts #I number of points +real wx, wy #I world coordinates +int delete #I delete points ? + +int i, j, pmltype +real r2min, r2, x0, y0 +int gstati() + +begin + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + if (delete == YES) { + + # Search for nearest point that has not been deleted. + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + next +$if (datatype == r) + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) +$else + call gctran (gd, real (xin[i]), real (yin[i]), x0, y0, 1, 0) +$endif + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark point and set weights to 0. + if (j != 0) { +$if (datatype == r) + call gscur (gd, xin[j], yin[j]) + call gmark (gd, xin[j], yin[j], GM_CROSS, 2., 2.) +$else + call gscur (gd, real(xin[j]), real(yin[j])) + call gmark (gd, real(xin[j]), real(yin[j]), GM_CROSS, 2., 2.) +$endif + wts[j] = PIXEL(0.0) + } + + } else { + + # Search for the nearest deleted point. + do i = 1, npts { + if (wts[i] > PIXEL(0.0)) + next +$if (datatype == r) + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) +$else + call gctran (gd, real(xin[i]), real(yin[i]), x0, y0, 1, 0) +$endif + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase cross and remark with a plus. + if (j != 0) { +$if (datatype == r) + call gscur (gd, xin[j], yin[j]) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, xin[j], yin[j], GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, xin[j], yin[j], GM_PLUS, 2., 2.) +$else + call gscur (gd, real(xin[j]), real(yin[j])) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, real(xin[j]), real(yin[j]), GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, real(xin[j]), real(yin[j]), GM_PLUS, 2., 2.) +$endif + wts[j] = userwts[j] + } + } +end + + +# GEO_2DELETE -- Delete the residuals. + +procedure geo_2delete$t (gd, x, resid, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +PIXEL x[ARB] #I reference x values +PIXEL resid[ARB] #I residuals +PIXEL wts[ARB] #I weight array +PIXEL userwts[ARB] #I user weight array +int npts #I number of points +real wx #I world x coordinate +real wy #I world y coordinate +int delete #I delete point + +int i, j, pmltype +real r2, r2min, x0, y0 +int gstati() + +begin + # Delete the point. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Delete or add a point. + if (delete == YES) { + + # Find the nearest undeleted point. + do i = 1, npts { + if (wts[i] <= PIXEL(0.0)) + next +$if (datatype == r) + call gctran (gd, x[i], resid[i], x0, y0, 1, 0) +$else + call gctran (gd, real(x[i]), real(resid[i]), x0, y0, 1, 0) +$endif + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the point with a cross and set weight to zero. + if (j != 0) { +$if (datatype == r) + call gscur (gd, x[j], resid[j]) + call gmark (gd, x[j], resid[j], GM_CROSS, 2., 2.) +$else + call gscur (gd, real(x[j]), real(resid[j])) + call gmark (gd, real(x[j]), real(resid[j]), GM_CROSS, 2., 2.) +$endif + wts[j] = PIXEL(0.0) + } + + } else { + + # Find the nearest deleted point. + do i = 1, npts { + if (wts[i] > PIXEL(0.0)) + next +$if (datatype == r) + call gctran (gd, x[i], resid[i], x0, y0, 1, 0) +$else + call gctran (gd, real(x[i]), real(resid[i]), x0, y0, 1, 0) +$endif + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase the cross and remark with a plus. + if (j != 0) { +$if (datatype == r) + call gscur (gd, x[j], resid[j]) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, x[j], resid[j], GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, x[j], resid[j], GM_PLUS, 2., 2.) +$else + call gscur (gd, real(x[j]), real(resid[j])) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, real(x[j]), real(resid[j]), GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, real(x[j]), real(resid[j]), GM_PLUS, 2., 2.) +$endif + wts[j] = userwts[j] + } + } +end + + +# GEO_1GRAPH - Procedure to graph the distribution of the data in the x-y +# plane. Rejected points are marked by a ' ' and deleted points are marked +# by a ' '. The shift in position of the data points are indicated by +# vectors. Sample fits of constant x and y are marked on the plots. + +procedure geo_1graph$t (gd, gt, fit, gfit, xref, yref, xin, yin, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to the geofit structure +pointer gfit #I pointer to the plot structure +PIXEL xref[ARB] #I x reference values +PIXEL yref[ARB] #I y reference values +PIXEL xin[ARB] #I x values +PIXEL yin[ARB] #I y values +PIXEL wts[ARB] #I array of weights +int npts #I number of points + +int i, j +$if (datatype == d) +pointer sp, rxin, ryin +$endif + +begin + # If previous plot different type don't overplot. + if (GG_PLOTTYPE(gfit) != FIT) + GG_OVERPLOT(gfit) = NO + + # If not overplottting start new plot. + if (GG_OVERPLOT(gfit) == NO) { + + # Set scale and axes. + call gclear (gd) +$if (datatype == r) + call gascale (gd, xin, npts, 1) + call gascale (gd, yin, npts, 2) +$else + call smark (sp) + call salloc (rxin, npts, TY_REAL) + call salloc (ryin, npts, TY_REAL) + call achtdr (xin, Memr[rxin], npts) + call achtdr (yin, Memr[ryin], npts) + call gascale (gd, Memr[rxin], npts, 1) + call gascale (gd, Memr[ryin], npts, 2) + call sfree (sp) +$endif + call gt_swind (gd, gt) + call gtlabax (gd, gt) + + # Mark the data and deleted points. + do i = 1, npts { +$if (datatype == r) + if (wts[i] == PIXEL(0.0)) + call gmark (gd, xin[i], yin[i], GM_CROSS, 2., 2.) + else + call gmark (gd, xin[i], yin[i], GM_PLUS, 2., 2.) +$else + if (wts[i] == PIXEL(0.0)) + call gmark (gd, real(xin[i]), real(yin[i]), GM_CROSS, + 2., 2.) + else + call gmark (gd, real(xin[i]), real(yin[i]), GM_PLUS, + 2., 2.) +$endif + } + + call gflush (gd) + } + + # Mark the rejected points. + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] +$if (datatype == r) + call gmark (gd, xin[j], yin[j], GM_CIRCLE, 2., 2.) +$else + call gmark (gd, real(xin[j]), real(yin[j]), GM_CIRCLE, 2., 2.) +$endif + } + + call gflush (gd) + + # Reset the status flags + GG_OVERPLOT(gfit) = NO +end + + +# GEO_2GRAPH -- Graph the x and y fit residuals versus x or y . + +procedure geo_2graph$t (gd, gt, fit, gfit, x, resid, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to geomap structure +pointer gfit #I pointer to the plot structure +PIXEL x[ARB] #I x reference values +PIXEL resid[ARB] #I residual +PIXEL wts[ARB] #I array of weights +int npts #I number of points + +int i, j +pointer sp, zero +$if (datatype == d) +pointer rxin, ryin +$endif + +begin + # Allocate space. + call smark (sp) + call salloc (zero, npts, TY_REAL) + call amovkr (0.0, Memr[zero], npts) + + # Calculate the residuals. + if (GG_PLOTTYPE(gfit) == FIT) + GG_OVERPLOT(gfit) = NO + + if (GG_OVERPLOT(gfit) == NO) { + + call gclear (gd) + + # Set scale and axes. +$if (datatype == r) + call gascale (gd, x, npts, 1) + call gascale (gd, resid, npts, 2) +$else + call salloc (rxin, npts, TY_REAL) + call salloc (ryin, npts, TY_REAL) + call achtdr (x, Memr[rxin], npts) + call achtdr (resid, Memr[ryin], npts) + call gascale (gd, Memr[rxin], npts, 1) + call gascale (gd, Memr[ryin], npts, 2) +$endif + call gt_swind (gd, gt) + call gtlabax (gd, gt) + +$if (datatype == r) + call gpline (gd, x, Memr[zero], npts) +$else + call gpline (gd, Memr[rxin], Memr[zero], npts) +$endif + } + + # Graph residuals and mark deleted points. + if (GG_OVERPLOT(gfit) == NO || GG_NEWFUNCTION(gfit) == YES) { + do i = 1, npts { +$if (datatype == r) + if (wts[i] == PIXEL(0.0)) + call gmark (gd, x[i], resid[i], GM_CROSS, 2., 2.) + else + call gmark (gd, x[i], resid[i], GM_PLUS, 2., 2.) +$else + if (wts[i] == PIXEL(0.0)) + call gmark (gd, Memr[rxin+i-1], Memr[ryin+i-1], + GM_CROSS, 2., 2.) + else + call gmark (gd, Memr[rxin+i-1], Memr[ryin+i-1], + GM_PLUS, 2., 2.) +$endif + } + } + + # plot rejected points + if (GM_NREJECT(fit) > 0) { + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] +$if (datatype == r) + call gmark (gd, x[j], resid[j], GM_CIRCLE, 2., 2.) +$else + call gmark (gd, Memr[rxin+j-1], Memr[ryin+j-1], GM_CIRCLE, + 2., 2.) +$endif + } + } + + # Reset the status flag. + GG_OVERPLOT(gfit) = NO + + call gflush (gd) + call sfree (sp) +end + + +# GEO_CONXY -- Plot a set of default lines of xref = const and yref = const. + +procedure geo_conxy$t (gd, fit, sx1, sy1, sx2, sy2) + +pointer gd #I graphics file descriptor +pointer fit #I fit descriptor +pointer sx1, sy1 #I pointer to the linear x and y surface fits +pointer sx2, sy2 #I pointer to the linear x and y surface fits + +int i +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +$if (datatype == d) +pointer xbuf, ybuf +$endif +PIXEL xint, yint, dx, dy + +begin + # allocate temporary space + call smark (sp) + call salloc (xtemp, NGRAPH, TY_PIXEL) + call salloc (ytemp, NGRAPH, TY_PIXEL) + call salloc (xfit1, NGRAPH, TY_PIXEL) + call salloc (yfit1, NGRAPH, TY_PIXEL) + call salloc (xfit2, NGRAPH, TY_PIXEL) + call salloc (yfit2, NGRAPH, TY_PIXEL) +$if (datatype == d) + call salloc (xbuf, NGRAPH, TY_REAL) + call salloc (ybuf, NGRAPH, TY_REAL) +$endif + + # Calculate intervals in x and y. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / NINTERVALS + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + + # Set up an array of y values. + Mem$t[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Mem$t[ytemp+i-1] = Mem$t[ytemp+i-2] + dy + + # Mark lines of constant x. + xint = GM_XMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # Set the x value. + call amovk$t (xint, Mem$t[xtemp], NGRAPH) + + # X fit. +$if (datatype == r) + call gsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$else + call dgsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$else + call dgsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[xfit1], Mem$t[xfit2], Mem$t[xfit1], NGRAPH) + } + + # Y fit. +$if (datatype == r) + call gsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$else + call dgsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$else + call dgsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[yfit1], Mem$t[yfit2], Mem$t[yfit1], NGRAPH) + } + + # Plot line of constant x. +$if (datatype == r) + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) +$else + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) +$endif + + # Update the x value. + xint = xint + dx + } + + call gflush (gd) + + # Calculate x and y intervals. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / NINTERVALS + + # Set up array of x values. + Mem$t[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Mem$t[xtemp+i-1] = Mem$t[xtemp+i-2] + dx + + # Mark lines of constant y. + yint = GM_YMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # set the y value + call amovk$t (yint, Mem$t[ytemp], NGRAPH) + + # X fit. +$if (datatype == r) + call gsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$else + call dgsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$else + call dgsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[xfit1], Mem$t[xfit2], Mem$t[xfit1], NGRAPH) + } + + + # Y fit. +$if (datatype == r) + call gsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$else + call dgsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$else + call dgsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[yfit1], Mem$t[yfit2], Mem$t[yfit1], NGRAPH) + } + + # Plot line of constant y. +$if (datatype == r) + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) +$else + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) +$endif + + # Update the y value. + yint = yint + dy + } + + call gflush (gd) + + call sfree (sp) +end + + +# GEO_LXY -- Draw a line of constant x-y. + +procedure geo_lxy$t (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, npts, + wx, wy) + +pointer gd #I pointer to graphics descriptor +pointer fit #I pointer to the fit parameters +pointer sx1 #I pointer to the linear x fit +pointer sy1 #I pointer to the linear y fit +pointer sx2 #I pointer to the higher order x fit +pointer sy2 #I pointer to the higher order y fit +PIXEL xref[ARB] #I x reference values +PIXEL yref[ARB] #I y reference values +PIXEL xin[ARB] #I x input values +PIXEL yin[ARB] #I y input values +int npts #I number of data points +real wx, wy #I x and y world coordinates + +int i, j +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +$if (datatype == d) +pointer xbuf, ybuf +$endif +real x0, y0, r2, r2min +PIXEL delta, deltax, deltay +$if (datatype == r) +real gseval() +$else +double dgseval() +$endif + +begin + # Transform world coordinates. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Find the nearest data point. + do i = 1, npts { +$if (datatype == r) + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) +$else + call gctran (gd, real(xin[i]), real(yin[i]), x0, y0, 1, 0) +$endif + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Fit the line + if (j != 0) { + + # Allocate temporary space. + call smark (sp) + call salloc (xtemp, NGRAPH, TY_PIXEL) + call salloc (ytemp, NGRAPH, TY_PIXEL) + call salloc (xfit1, NGRAPH, TY_PIXEL) + call salloc (yfit1, NGRAPH, TY_PIXEL) + call salloc (xfit2, NGRAPH, TY_PIXEL) + call salloc (yfit2, NGRAPH, TY_PIXEL) +$if (datatype == d) + call salloc (xbuf, NGRAPH, TY_REAL) + call salloc (ybuf, NGRAPH, TY_REAL) +$endif + + # Compute the deltas. +$if (datatype == r) + deltax = xin[j] - gseval (sx1, xref[j], yref[j]) + if (sx2 != NULL) + deltax = deltax - gseval (sx2, xref[j], yref[j]) + deltay = yin[j] - gseval (sy1, xref[j], yref[j]) + if (sy2 != NULL) + deltay = deltay - gseval (sy2, xref[j], yref[j]) +$else + deltax = xin[j] - dgseval (sx1, xref[j], yref[j]) + if (sx2 != NULL) + deltax = deltax - dgseval (sx2, xref[j], yref[j]) + deltay = yin[j] - dgseval (sy1, xref[j], yref[j]) + if (sy2 != NULL) + deltay = deltay - dgseval (sy2, xref[j], yref[j]) +$endif + + # Set up line of constant x. + call amovk$t (xref[j], Mem$t[xtemp], NGRAPH) + delta = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + Mem$t[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Mem$t[ytemp+i-1] = Mem$t[ytemp+i-2] + delta + + # X solution. +$if (datatype == r) + call gsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$else + call dgsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$else + call dgsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[xfit1], Mem$t[xfit2], Mem$t[xfit1], NGRAPH) + } + call aaddk$t (Mem$t[xfit1], deltax, Mem$t[xfit1], NGRAPH) + + # Y solution. +$if (datatype == r) + call gsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$else + call dgsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$else + call dgsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[yfit1], Mem$t[yfit2], Mem$t[yfit1], NGRAPH) + } + call aaddk$t (Mem$t[yfit1], deltay, Mem$t[yfit1], NGRAPH) + + # Plot line of constant x. +$if (datatype == r) + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) +$else + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) +$endif + call gflush (gd) + + # Set up line of constant y. + call amovk$t (yref[j], Mem$t[ytemp], NGRAPH) + delta = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + Mem$t[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Mem$t[xtemp+i-1] = Mem$t[xtemp+i-2] + delta + + # X fit. +$if (datatype == r) + call gsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$else + call dgsvector (sx1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit1], + NGRAPH) +$endif + if (sx2 != NULL) { +$if (datatype == r) + call gsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$else + call dgsvector (sx2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[xfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[xfit1], Mem$t[xfit2], Mem$t[xfit1], NGRAPH) + } + call aaddk$t (Mem$t[xfit1], deltax, Mem$t[xfit1], NGRAPH) + + # Y fit. +$if (datatype == r) + call gsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$else + call dgsvector (sy1, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit1], + NGRAPH) +$endif + if (sy2 != NULL) { +$if (datatype == r) + call gsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$else + call dgsvector (sy2, Mem$t[xtemp], Mem$t[ytemp], Mem$t[yfit2], + NGRAPH) +$endif + call aadd$t (Mem$t[yfit1], Mem$t[yfit2], Mem$t[yfit1], NGRAPH) + } + call aaddk$t (Mem$t[yfit1], deltay, Mem$t[yfit1], NGRAPH) + + # Plot line of constant y. +$if (datatype == r) + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) +$else + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) +$endif + call gflush (gd) + + # Free space. + call sfree (sp) + } +end + + +# GEO_GCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, + +procedure geo_gcoeff$t (sx, sy, xshift, yshift, a, b, c, d) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +PIXEL xshift #O output x shift +PIXEL yshift #O output y shift +PIXEL a #O output x coefficient of x fit +PIXEL b #O output y coefficient of x fit +PIXEL c #O output x coefficient of y fit +PIXEL d #O output y coefficient of y fit + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +PIXEL xxrange, xyrange, xxmaxmin, xymaxmin +PIXEL yxrange, yyrange, yxmaxmin, yymaxmin + +$if (datatype == r) +int gsgeti() +real gsgetr() +$else +int dgsgeti() +double dgsgetd() +$endif + +begin + # Allocate working space. + call smark (sp) +$if (datatype == r) + call salloc (xcoeff, gsgeti (sx, GSNCOEFF), TY_PIXEL) + call salloc (ycoeff, gsgeti (sy, GSNCOEFF), TY_PIXEL) +$else + call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_PIXEL) + call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_PIXEL) +$endif + + # Get coefficients and numbers of coefficients. +$if (datatype == r) + call gscoeff (sx, Mem$t[xcoeff], nxxcoeff) + call gscoeff (sy, Mem$t[ycoeff], nyycoeff) + nxxcoeff = gsgeti (sx, GSNXCOEFF) + nxycoeff = gsgeti (sx, GSNYCOEFF) + nyxcoeff = gsgeti (sy, GSNXCOEFF) + nyycoeff = gsgeti (sy, GSNYCOEFF) +$else + call dgscoeff (sx, Mem$t[xcoeff], nxxcoeff) + call dgscoeff (sy, Mem$t[ycoeff], nyycoeff) + nxxcoeff = dgsgeti (sx, GSNXCOEFF) + nxycoeff = dgsgeti (sx, GSNYCOEFF) + nyxcoeff = dgsgeti (sy, GSNXCOEFF) + nyycoeff = dgsgeti (sy, GSNYCOEFF) +$endif + + # Get the data range. +$if (datatype == r) + if (gsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (gsgetr (sx, GSXMAX) - gsgetr (sx, GSXMIN)) / 2.0 + xxmaxmin = - (gsgetr (sx, GSXMAX) + gsgetr (sx, GSXMIN)) / 2.0 + xyrange = (gsgetr (sx, GSYMAX) - gsgetr (sx, GSYMIN)) / 2.0 + xymaxmin = - (gsgetr (sx, GSYMAX) + gsgetr (sx, GSYMIN)) / 2.0 +$else + if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 + xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 + xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 + xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 +$endif + } else { + xxrange = PIXEL(1.0) + xxmaxmin = PIXEL(0.0) + xyrange = PIXEL(1.0) + xymaxmin = PIXEL(0.0) + } + +$if (datatype == r) + if (gsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (gsgetr (sy, GSXMAX) - gsgetr (sy, GSXMIN)) / 2.0 + yxmaxmin = - (gsgetr (sy, GSXMAX) + gsgetr (sy, GSXMIN)) / 2.0 + yyrange = (gsgetr (sy, GSYMAX) - gsgetr (sy, GSYMIN)) / 2.0 + yymaxmin = - (gsgetr (sy, GSYMAX) + gsgetr (sy, GSYMIN)) / 2.0 +$else + if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 + yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 + yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 + yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 +$endif + } else { + yxrange = PIXEL(1.0) + yxmaxmin = PIXEL(0.0) + yyrange = PIXEL(1.0) + yymaxmin = PIXEL(0.0) + } + + # Get the shifts. + xshift = Mem$t[xcoeff] + Mem$t[xcoeff+1] * xxmaxmin / xxrange + + Mem$t[xcoeff+2] * xymaxmin / xyrange + yshift = Mem$t[ycoeff] + Mem$t[ycoeff+1] * yxmaxmin / yxrange + + Mem$t[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Mem$t[xcoeff+1] / xxrange + else + a = PIXEL(0.0) + if (nxycoeff > 1) + b = Mem$t[xcoeff+nxxcoeff] / xyrange + else + b = PIXEL(0.0) + if (nyxcoeff > 1) + c = Mem$t[ycoeff+1] / yxrange + else + c = PIXEL(0.0) + if (nyycoeff > 1) + d = Mem$t[ycoeff+nyxcoeff] / yyrange + else + d = PIXEL(0.0) + + call sfree (sp) +end + +$endfor diff --git a/pkg/images/lib/geograph.x b/pkg/images/lib/geograph.x new file mode 100644 index 00000000..6597311a --- /dev/null +++ b/pkg/images/lib/geograph.x @@ -0,0 +1,1740 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "geomap.h" +include "geogmap.h" + +define MAX_PARAMS (10 * SZ_LINE) +define NINTERVALS 5 +define NGRAPH 100 + + + +# GEO_LABEL -- Annotate the plot. + +procedure geo_label (plot_type, gt, fit) + +int plot_type #I type of plot +pointer gt #I gtools descriptor +pointer fit #I geomap fit parameters + +int npts +pointer sp, params, xtermlab, ytermlab +real xrms, yrms, rej +int strlen(), rg_wrdstr() + +begin + call smark (sp) + call salloc (params, MAX_PARAMS, TY_CHAR) + call salloc (xtermlab, SZ_FNAME, TY_CHAR) + call salloc (ytermlab, SZ_FNAME, TY_CHAR) + + npts = max (0, GM_NPTS(fit) - GM_NWTS0(fit)) + xrms = max (0.0d0, GM_XRMS(fit)) + yrms = max (0.0d0, GM_YRMS(fit)) + if (npts > 1) { + xrms = sqrt (xrms / (npts - 1)) + yrms = sqrt (yrms / (npts - 1)) + } else { + xrms = 0.0 + yrms = 0.0 + } + if (IS_INDEFD(GM_REJECT(fit))) + rej = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rej = INDEFR + else + rej = GM_REJECT(fit) + + # Print data parameters. + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params], MAX_PARAMS, + "GEOMAP: function = %s npts = %d reject = %g nrej = %d\n") + else + call sprintf (Memc[params], MAX_PARAMS, + "CCMAP: function = %s npts = %d reject = %g nrej = %d\n") + + switch (GM_FUNCTION(fit)) { + case GS_LEGENDRE: + call pargstr ("legendre") + case GS_CHEBYSHEV: + call pargstr ("chebyshev") + case GS_POLYNOMIAL: + call pargstr ("polynomial") + } + call pargi (GM_NPTS(fit)) + call pargr (rej) + call pargi (GM_NWTS0(fit)) + + # Print fit parameters. + switch (plot_type) { + case FIT: + + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[xtermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[xtermlab], SZ_FNAME) + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[ytermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[ytermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "X fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "XI fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g arcsec\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargstr (Memc[xtermlab]) + call pargr (xrms) + + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "Y fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "ETA fit: xorder = %d yorder = %d xterms = %s stdev = %8.3g arcsec\n") + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + call pargstr (Memc[ytermlab]) + call pargr (yrms) + + case XXRESID, XYRESID: + + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[xtermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[xtermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "X fit: xorder = %d yorder = %d xterms = %s rms = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "XI fit: xorder = %d yorder = %d xterms = %s rms = %8.3g arcsec\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargstr (Memc[xtermlab]) + call pargr (xrms) + + case YXRESID, YYRESID: + + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[ytermlab], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[ytermlab], SZ_FNAME) + if (GM_PROJECTION(fit) == GM_NONE) + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "Y fit: xorder = %d yorder = %d xterms = %s rms = %8.3g\n") + else + call sprintf (Memc[params+strlen(Memc[params])], MAX_PARAMS, + "ETA fit: xorder = %d yorder = %d xterms = %s rms = %8.3g arcsec\n") + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + call pargstr (Memc[ytermlab]) + call pargr (yrms) + + default: + + # do nothing gracefully + } + + call gt_sets (gt, GTPARAMS, Memc[params]) + + call sfree (sp) +end + + +# GEO_GTSET -- Write title and labels. + +procedure geo_gtset (plot_type, gt, fit) + +int plot_type #I plot type +pointer gt #I plot descriptor +pointer fit #I fit descriptor + +char str[SZ_LINE] +int nchars +int gstrcpy() + +begin + nchars = gstrcpy (GM_RECORD(fit), str, SZ_LINE) + + switch (plot_type) { + case FIT: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Coordinate Transformation", str[nchars+1], + SZ_LINE) + else + call strcpy (": Celestial Coordinate Transformation", + str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (in units)") + call gt_sets (gt, GTYLABEL, "Y (in units)") + } else { + call gt_sets (gt, GTXLABEL, "XI (arcsec)") + call gt_sets (gt, GTYLABEL, "ETA (arcsec)") + } + + case XXRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": X fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": XI fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (ref units)") + call gt_sets (gt, GTYLABEL, "X Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "X (pixels)") + call gt_sets (gt, GTYLABEL, "XI Residuals (arcsec)") + } + + case XYRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": X fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": XI fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "Y (ref units)") + call gt_sets (gt, GTYLABEL, "X Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "Y (pixels)") + call gt_sets (gt, GTYLABEL, "XI Residuals (arcsec)") + } + + case YXRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Y fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": ETA fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "X (ref units)") + call gt_sets (gt, GTYLABEL, "Y (Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "X (pixels)") + call gt_sets (gt, GTYLABEL, "ETA Residuals (arcsec)") + } + + case YYRESID: + + if (GM_PROJECTION(fit) == GM_NONE) + call strcpy (": Y fit Residuals", str[nchars+1], SZ_LINE) + else + call strcpy (": ETA fit Residuals", str[nchars+1], SZ_LINE) + call gt_sets (gt, GTTITLE, str) + if (GM_PROJECTION(fit) == GM_NONE) { + call gt_sets (gt, GTXLABEL, "Y (ref units)") + call gt_sets (gt, GTYLABEL, "Y Residuals (in units)") + } else { + call gt_sets (gt, GTXLABEL, "Y (pixels)") + call gt_sets (gt, GTYLABEL, "ETA Residuals (arcsec)") + } + + default: + + # do nothing gracefully + } +end + + +# GEO_COLON -- Process the colon commands. + +procedure geo_colon (gd, fit, gfit, cmdstr, newgraph) + +pointer gd #I graphics stream +pointer fit #I pointer to fit structure +pointer gfit #I pointer to the gfit structure +char cmdstr[ARB] #I command string +int newgraph #I plot new graph + +int ncmd, ival +pointer sp, str, cmd +real rval +int nscan(), strdic(), rg_wrdstr() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 0) { + call sfree (sp) + return + } + + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_CMDS) + switch (ncmd) { + case GMCMD_SHOW: + call gdeactivate (gd, AW_CLEAR) + call printf ("Current Fitting Parameters\n\n") + if (GM_PROJECTION(fit) != GM_NONE) { + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + ; + call printf ("\tprojection = %s\n") + call pargstr (Memc[str]) + call printf ("\tlngref = %h\n") + call pargd (GM_XREFPT(fit)) + call printf ("\tlatref = %h\n") + call pargd (GM_YREFPT(fit)) + } + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, + GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call printf ("\tfitgeometry = %s\n") + call pargstr (Memc[str]) + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, + GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call printf ("\tfunction = %s\n") + Call pargstr (Memc[str]) + call printf ("\txxorder = %d\n") + call pargi (GM_XXORDER(fit)) + call printf ("\txyorder = %d\n") + call pargi (GM_XYORDER(fit)) + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("\txxterms = %s\n") + call pargstr (Memc[str]) + call printf ("\tyxorder = %d\n") + call pargi (GM_YXORDER(fit)) + call printf ("\tyyorder = %d\n") + call pargi (GM_YYORDER(fit)) + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("\tyxterms = %s\n") + call pargstr (Memc[str]) + if (IS_INDEFD(GM_REJECT(fit))) + rval = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rval = INDEFR + else + rval = GM_REJECT(fit) + call printf ("\treject = %f\n") + call pargr (rval) + call greactivate (gd, AW_PAUSE) + + case GMCMD_PROJECTION: + if (rg_wrdstr (GM_PROJECTION(fit), Memc[str], SZ_FNAME, + GM_PROJLIST) <= 0) + call strcpy ("INDEF", Memc[str], SZ_FNAME) + call printf ("projection = %s\n") + call pargstr (Memc[str]) + + case GMCMD_REFPOINT: + call printf ("lngref = %h latref = %h\n") + call pargd (GM_XREFPT(fit)) + call pargd (GM_YREFPT(fit)) + + case GMCMD_GEOMETRY: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr (GM_FIT(fit), Memc[str], SZ_FNAME, + GM_GEOMETRIES) <= 0) + call strcpy ("general", Memc[str], SZ_FNAME) + call printf ("fitgeometry = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_GEOMETRIES) + if (ival > 0) { + GM_FIT(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_FUNCTION: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr (GM_FUNCTION(fit), Memc[str], SZ_FNAME, + GM_FUNCS) <= 0) + call strcpy ("polynomial", Memc[str], SZ_FNAME) + call printf ("function = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_FUNCS) + if (ival > 0) { + GM_FUNCTION(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_ORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ( + "xxorder = %d xyorder = %d yxorder = %d yyorder = %d\n") + call pargi (GM_XXORDER(fit)) + call pargi (GM_XYORDER(fit)) + call pargi (GM_YXORDER(fit)) + call pargi (GM_YYORDER(fit)) + } else { + GM_XXORDER(fit) = max (ival, 2) + GM_XYORDER(fit) = max (ival, 2) + GM_YXORDER(fit) = max (ival, 2) + GM_YYORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XXORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("xxorder = %d\n") + call pargi (GM_XXORDER(fit)) + } else { + GM_XXORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XYORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("xyorder = %d\n") + call pargi (GM_XYORDER(fit)) + } else { + GM_XYORDER(fit) = max (ival,2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_YXORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("yxorder = %d\n") + call pargi (GM_YXORDER(fit)) + } else { + GM_YXORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_YYORDER: + call gargi (ival) + if (nscan () == 1) { + call printf ("yyorder = %d\n") + call pargi (GM_YYORDER(fit)) + } else { + GM_YYORDER(fit) = max (ival, 2) + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_XXTERMS: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr ((GM_XXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("xxterms = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_XFUNCS) + if (ival > 0) { + GM_XXTERMS(fit) = ival - 1 + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_YXTERMS: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan () == 1) { + if (rg_wrdstr ((GM_YXTERMS(fit) + 1), Memc[str], SZ_FNAME, + GM_XFUNCS) <= 0) + call strcpy ("none", Memc[str], SZ_FNAME) + call printf ("yxterms = %s\n") + call pargstr (Memc[str]) + } else { + ival = strdic (Memc[cmd], Memc[cmd], SZ_LINE, GM_XFUNCS) + if (ival > 0) { + GM_YXTERMS(fit) = ival - 1 + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + } + + case GMCMD_REJECT: + call gargr (rval) + if (nscan() == 1) { + if (IS_INDEFD(GM_REJECT(fit))) + rval = INDEFR + else if (GM_REJECT(fit) > MAX_REAL) + rval = INDEFR + else + rval = GM_REJECT(fit) + call printf ("reject = %f\n") + call pargr (rval) + } else { + GM_REJECT(fit) = rval + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + case GMCMD_MAXITER: + call gargi (ival) + if (nscan() == 1) { + call printf ("maxiter = %d\n") + call pargi (GM_MAXITER(fit)) + } else { + GM_MAXITER(fit) = ival + GG_NEWFUNCTION(gfit) = YES + GG_FITERROR(gfit) = NO + } + + } + + call sfree (sp) +end + + + + + + +# GEO_1DELETE -- Delete a point from the fit. + +procedure geo_1deleter (gd, xin, yin, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +real xin[ARB] #I x array +real yin[ARB] #I y array +real wts[ARB] #I array of weights +real userwts[ARB] #I array of user weights +int npts #I number of points +real wx, wy #I world coordinates +int delete #I delete points ? + +int i, j, pmltype +real r2min, r2, x0, y0 +int gstati() + +begin + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + if (delete == YES) { + + # Search for nearest point that has not been deleted. + do i = 1, npts { + if (wts[i] <= real(0.0)) + next + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark point and set weights to 0. + if (j != 0) { + call gscur (gd, xin[j], yin[j]) + call gmark (gd, xin[j], yin[j], GM_CROSS, 2., 2.) + wts[j] = real(0.0) + } + + } else { + + # Search for the nearest deleted point. + do i = 1, npts { + if (wts[i] > real(0.0)) + next + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase cross and remark with a plus. + if (j != 0) { + call gscur (gd, xin[j], yin[j]) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, xin[j], yin[j], GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, xin[j], yin[j], GM_PLUS, 2., 2.) + wts[j] = userwts[j] + } + } +end + + +# GEO_2DELETE -- Delete the residuals. + +procedure geo_2deleter (gd, x, resid, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +real x[ARB] #I reference x values +real resid[ARB] #I residuals +real wts[ARB] #I weight array +real userwts[ARB] #I user weight array +int npts #I number of points +real wx #I world x coordinate +real wy #I world y coordinate +int delete #I delete point + +int i, j, pmltype +real r2, r2min, x0, y0 +int gstati() + +begin + # Delete the point. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Delete or add a point. + if (delete == YES) { + + # Find the nearest undeleted point. + do i = 1, npts { + if (wts[i] <= real(0.0)) + next + call gctran (gd, x[i], resid[i], x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the point with a cross and set weight to zero. + if (j != 0) { + call gscur (gd, x[j], resid[j]) + call gmark (gd, x[j], resid[j], GM_CROSS, 2., 2.) + wts[j] = real(0.0) + } + + } else { + + # Find the nearest deleted point. + do i = 1, npts { + if (wts[i] > real(0.0)) + next + call gctran (gd, x[i], resid[i], x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase the cross and remark with a plus. + if (j != 0) { + call gscur (gd, x[j], resid[j]) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, x[j], resid[j], GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, x[j], resid[j], GM_PLUS, 2., 2.) + wts[j] = userwts[j] + } + } +end + + +# GEO_1GRAPH - Procedure to graph the distribution of the data in the x-y +# plane. Rejected points are marked by a ' ' and deleted points are marked +# by a ' '. The shift in position of the data points are indicated by +# vectors. Sample fits of constant x and y are marked on the plots. + +procedure geo_1graphr (gd, gt, fit, gfit, xref, yref, xin, yin, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to the geofit structure +pointer gfit #I pointer to the plot structure +real xref[ARB] #I x reference values +real yref[ARB] #I y reference values +real xin[ARB] #I x values +real yin[ARB] #I y values +real wts[ARB] #I array of weights +int npts #I number of points + +int i, j + +begin + # If previous plot different type don't overplot. + if (GG_PLOTTYPE(gfit) != FIT) + GG_OVERPLOT(gfit) = NO + + # If not overplottting start new plot. + if (GG_OVERPLOT(gfit) == NO) { + + # Set scale and axes. + call gclear (gd) + call gascale (gd, xin, npts, 1) + call gascale (gd, yin, npts, 2) + call gt_swind (gd, gt) + call gtlabax (gd, gt) + + # Mark the data and deleted points. + do i = 1, npts { + if (wts[i] == real(0.0)) + call gmark (gd, xin[i], yin[i], GM_CROSS, 2., 2.) + else + call gmark (gd, xin[i], yin[i], GM_PLUS, 2., 2.) + } + + call gflush (gd) + } + + # Mark the rejected points. + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] + call gmark (gd, xin[j], yin[j], GM_CIRCLE, 2., 2.) + } + + call gflush (gd) + + # Reset the status flags + GG_OVERPLOT(gfit) = NO +end + + +# GEO_2GRAPH -- Graph the x and y fit residuals versus x or y . + +procedure geo_2graphr (gd, gt, fit, gfit, x, resid, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to geomap structure +pointer gfit #I pointer to the plot structure +real x[ARB] #I x reference values +real resid[ARB] #I residual +real wts[ARB] #I array of weights +int npts #I number of points + +int i, j +pointer sp, zero + +begin + # Allocate space. + call smark (sp) + call salloc (zero, npts, TY_REAL) + call amovkr (0.0, Memr[zero], npts) + + # Calculate the residuals. + if (GG_PLOTTYPE(gfit) == FIT) + GG_OVERPLOT(gfit) = NO + + if (GG_OVERPLOT(gfit) == NO) { + + call gclear (gd) + + # Set scale and axes. + call gascale (gd, x, npts, 1) + call gascale (gd, resid, npts, 2) + call gt_swind (gd, gt) + call gtlabax (gd, gt) + + call gpline (gd, x, Memr[zero], npts) + } + + # Graph residuals and mark deleted points. + if (GG_OVERPLOT(gfit) == NO || GG_NEWFUNCTION(gfit) == YES) { + do i = 1, npts { + if (wts[i] == real(0.0)) + call gmark (gd, x[i], resid[i], GM_CROSS, 2., 2.) + else + call gmark (gd, x[i], resid[i], GM_PLUS, 2., 2.) + } + } + + # plot rejected points + if (GM_NREJECT(fit) > 0) { + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] + call gmark (gd, x[j], resid[j], GM_CIRCLE, 2., 2.) + } + } + + # Reset the status flag. + GG_OVERPLOT(gfit) = NO + + call gflush (gd) + call sfree (sp) +end + + +# GEO_CONXY -- Plot a set of default lines of xref = const and yref = const. + +procedure geo_conxyr (gd, fit, sx1, sy1, sx2, sy2) + +pointer gd #I graphics file descriptor +pointer fit #I fit descriptor +pointer sx1, sy1 #I pointer to the linear x and y surface fits +pointer sx2, sy2 #I pointer to the linear x and y surface fits + +int i +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +real xint, yint, dx, dy + +begin + # allocate temporary space + call smark (sp) + call salloc (xtemp, NGRAPH, TY_REAL) + call salloc (ytemp, NGRAPH, TY_REAL) + call salloc (xfit1, NGRAPH, TY_REAL) + call salloc (yfit1, NGRAPH, TY_REAL) + call salloc (xfit2, NGRAPH, TY_REAL) + call salloc (yfit2, NGRAPH, TY_REAL) + + # Calculate intervals in x and y. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / NINTERVALS + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + + # Set up an array of y values. + Memr[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Memr[ytemp+i-1] = Memr[ytemp+i-2] + dy + + # Mark lines of constant x. + xint = GM_XMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # Set the x value. + call amovkr (xint, Memr[xtemp], NGRAPH) + + # X fit. + call gsvector (sx1, Memr[xtemp], Memr[ytemp], Memr[xfit1], + NGRAPH) + if (sx2 != NULL) { + call gsvector (sx2, Memr[xtemp], Memr[ytemp], Memr[xfit2], + NGRAPH) + call aaddr (Memr[xfit1], Memr[xfit2], Memr[xfit1], NGRAPH) + } + + # Y fit. + call gsvector (sy1, Memr[xtemp], Memr[ytemp], Memr[yfit1], + NGRAPH) + if (sy2 != NULL) { + call gsvector (sy2, Memr[xtemp], Memr[ytemp], Memr[yfit2], + NGRAPH) + call aaddr (Memr[yfit1], Memr[yfit2], Memr[yfit1], NGRAPH) + } + + # Plot line of constant x. + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) + + # Update the x value. + xint = xint + dx + } + + call gflush (gd) + + # Calculate x and y intervals. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / NINTERVALS + + # Set up array of x values. + Memr[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Memr[xtemp+i-1] = Memr[xtemp+i-2] + dx + + # Mark lines of constant y. + yint = GM_YMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # set the y value + call amovkr (yint, Memr[ytemp], NGRAPH) + + # X fit. + call gsvector (sx1, Memr[xtemp], Memr[ytemp], Memr[xfit1], + NGRAPH) + if (sx2 != NULL) { + call gsvector (sx2, Memr[xtemp], Memr[ytemp], Memr[xfit2], + NGRAPH) + call aaddr (Memr[xfit1], Memr[xfit2], Memr[xfit1], NGRAPH) + } + + + # Y fit. + call gsvector (sy1, Memr[xtemp], Memr[ytemp], Memr[yfit1], + NGRAPH) + if (sy2 != NULL) { + call gsvector (sy2, Memr[xtemp], Memr[ytemp], Memr[yfit2], + NGRAPH) + call aaddr (Memr[yfit1], Memr[yfit2], Memr[yfit1], NGRAPH) + } + + # Plot line of constant y. + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) + + # Update the y value. + yint = yint + dy + } + + call gflush (gd) + + call sfree (sp) +end + + +# GEO_LXY -- Draw a line of constant x-y. + +procedure geo_lxyr (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, npts, + wx, wy) + +pointer gd #I pointer to graphics descriptor +pointer fit #I pointer to the fit parameters +pointer sx1 #I pointer to the linear x fit +pointer sy1 #I pointer to the linear y fit +pointer sx2 #I pointer to the higher order x fit +pointer sy2 #I pointer to the higher order y fit +real xref[ARB] #I x reference values +real yref[ARB] #I y reference values +real xin[ARB] #I x input values +real yin[ARB] #I y input values +int npts #I number of data points +real wx, wy #I x and y world coordinates + +int i, j +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +real x0, y0, r2, r2min +real delta, deltax, deltay +real gseval() + +begin + # Transform world coordinates. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Find the nearest data point. + do i = 1, npts { + call gctran (gd, xin[i], yin[i], x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Fit the line + if (j != 0) { + + # Allocate temporary space. + call smark (sp) + call salloc (xtemp, NGRAPH, TY_REAL) + call salloc (ytemp, NGRAPH, TY_REAL) + call salloc (xfit1, NGRAPH, TY_REAL) + call salloc (yfit1, NGRAPH, TY_REAL) + call salloc (xfit2, NGRAPH, TY_REAL) + call salloc (yfit2, NGRAPH, TY_REAL) + + # Compute the deltas. + deltax = xin[j] - gseval (sx1, xref[j], yref[j]) + if (sx2 != NULL) + deltax = deltax - gseval (sx2, xref[j], yref[j]) + deltay = yin[j] - gseval (sy1, xref[j], yref[j]) + if (sy2 != NULL) + deltay = deltay - gseval (sy2, xref[j], yref[j]) + + # Set up line of constant x. + call amovkr (xref[j], Memr[xtemp], NGRAPH) + delta = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + Memr[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Memr[ytemp+i-1] = Memr[ytemp+i-2] + delta + + # X solution. + call gsvector (sx1, Memr[xtemp], Memr[ytemp], Memr[xfit1], + NGRAPH) + if (sx2 != NULL) { + call gsvector (sx2, Memr[xtemp], Memr[ytemp], Memr[xfit2], + NGRAPH) + call aaddr (Memr[xfit1], Memr[xfit2], Memr[xfit1], NGRAPH) + } + call aaddkr (Memr[xfit1], deltax, Memr[xfit1], NGRAPH) + + # Y solution. + call gsvector (sy1, Memr[xtemp], Memr[ytemp], Memr[yfit1], + NGRAPH) + if (sy2 != NULL) { + call gsvector (sy2, Memr[xtemp], Memr[ytemp], Memr[yfit2], + NGRAPH) + call aaddr (Memr[yfit1], Memr[yfit2], Memr[yfit1], NGRAPH) + } + call aaddkr (Memr[yfit1], deltay, Memr[yfit1], NGRAPH) + + # Plot line of constant x. + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) + call gflush (gd) + + # Set up line of constant y. + call amovkr (yref[j], Memr[ytemp], NGRAPH) + delta = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + Memr[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Memr[xtemp+i-1] = Memr[xtemp+i-2] + delta + + # X fit. + call gsvector (sx1, Memr[xtemp], Memr[ytemp], Memr[xfit1], + NGRAPH) + if (sx2 != NULL) { + call gsvector (sx2, Memr[xtemp], Memr[ytemp], Memr[xfit2], + NGRAPH) + call aaddr (Memr[xfit1], Memr[xfit2], Memr[xfit1], NGRAPH) + } + call aaddkr (Memr[xfit1], deltax, Memr[xfit1], NGRAPH) + + # Y fit. + call gsvector (sy1, Memr[xtemp], Memr[ytemp], Memr[yfit1], + NGRAPH) + if (sy2 != NULL) { + call gsvector (sy2, Memr[xtemp], Memr[ytemp], Memr[yfit2], + NGRAPH) + call aaddr (Memr[yfit1], Memr[yfit2], Memr[yfit1], NGRAPH) + } + call aaddkr (Memr[yfit1], deltay, Memr[yfit1], NGRAPH) + + # Plot line of constant y. + call gpline (gd, Memr[xfit1], Memr[yfit1], NGRAPH) + call gflush (gd) + + # Free space. + call sfree (sp) + } +end + + +# GEO_GCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, + +procedure geo_gcoeffr (sx, sy, xshift, yshift, a, b, c, d) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +real xshift #O output x shift +real yshift #O output y shift +real a #O output x coefficient of x fit +real b #O output y coefficient of x fit +real c #O output x coefficient of y fit +real d #O output y coefficient of y fit + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +real xxrange, xyrange, xxmaxmin, xymaxmin +real yxrange, yyrange, yxmaxmin, yymaxmin + +int gsgeti() +real gsgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, gsgeti (sx, GSNCOEFF), TY_REAL) + call salloc (ycoeff, gsgeti (sy, GSNCOEFF), TY_REAL) + + # Get coefficients and numbers of coefficients. + call gscoeff (sx, Memr[xcoeff], nxxcoeff) + call gscoeff (sy, Memr[ycoeff], nyycoeff) + nxxcoeff = gsgeti (sx, GSNXCOEFF) + nxycoeff = gsgeti (sx, GSNYCOEFF) + nyxcoeff = gsgeti (sy, GSNXCOEFF) + nyycoeff = gsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (gsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (gsgetr (sx, GSXMAX) - gsgetr (sx, GSXMIN)) / 2.0 + xxmaxmin = - (gsgetr (sx, GSXMAX) + gsgetr (sx, GSXMIN)) / 2.0 + xyrange = (gsgetr (sx, GSYMAX) - gsgetr (sx, GSYMIN)) / 2.0 + xymaxmin = - (gsgetr (sx, GSYMAX) + gsgetr (sx, GSYMIN)) / 2.0 + } else { + xxrange = real(1.0) + xxmaxmin = real(0.0) + xyrange = real(1.0) + xymaxmin = real(0.0) + } + + if (gsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (gsgetr (sy, GSXMAX) - gsgetr (sy, GSXMIN)) / 2.0 + yxmaxmin = - (gsgetr (sy, GSXMAX) + gsgetr (sy, GSXMIN)) / 2.0 + yyrange = (gsgetr (sy, GSYMAX) - gsgetr (sy, GSYMIN)) / 2.0 + yymaxmin = - (gsgetr (sy, GSYMAX) + gsgetr (sy, GSYMIN)) / 2.0 + } else { + yxrange = real(1.0) + yxmaxmin = real(0.0) + yyrange = real(1.0) + yymaxmin = real(0.0) + } + + # Get the shifts. + xshift = Memr[xcoeff] + Memr[xcoeff+1] * xxmaxmin / xxrange + + Memr[xcoeff+2] * xymaxmin / xyrange + yshift = Memr[ycoeff] + Memr[ycoeff+1] * yxmaxmin / yxrange + + Memr[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memr[xcoeff+1] / xxrange + else + a = real(0.0) + if (nxycoeff > 1) + b = Memr[xcoeff+nxxcoeff] / xyrange + else + b = real(0.0) + if (nyxcoeff > 1) + c = Memr[ycoeff+1] / yxrange + else + c = real(0.0) + if (nyycoeff > 1) + d = Memr[ycoeff+nyxcoeff] / yyrange + else + d = real(0.0) + + call sfree (sp) +end + + + +# GEO_1DELETE -- Delete a point from the fit. + +procedure geo_1deleted (gd, xin, yin, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +double xin[ARB] #I x array +double yin[ARB] #I y array +double wts[ARB] #I array of weights +double userwts[ARB] #I array of user weights +int npts #I number of points +real wx, wy #I world coordinates +int delete #I delete points ? + +int i, j, pmltype +real r2min, r2, x0, y0 +int gstati() + +begin + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + if (delete == YES) { + + # Search for nearest point that has not been deleted. + do i = 1, npts { + if (wts[i] <= double(0.0)) + next + call gctran (gd, real (xin[i]), real (yin[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark point and set weights to 0. + if (j != 0) { + call gscur (gd, real(xin[j]), real(yin[j])) + call gmark (gd, real(xin[j]), real(yin[j]), GM_CROSS, 2., 2.) + wts[j] = double(0.0) + } + + } else { + + # Search for the nearest deleted point. + do i = 1, npts { + if (wts[i] > double(0.0)) + next + call gctran (gd, real(xin[i]), real(yin[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase cross and remark with a plus. + if (j != 0) { + call gscur (gd, real(xin[j]), real(yin[j])) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, real(xin[j]), real(yin[j]), GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, real(xin[j]), real(yin[j]), GM_PLUS, 2., 2.) + wts[j] = userwts[j] + } + } +end + + +# GEO_2DELETE -- Delete the residuals. + +procedure geo_2deleted (gd, x, resid, wts, userwts, npts, wx, wy, delete) + +pointer gd #I pointer to graphics descriptor +double x[ARB] #I reference x values +double resid[ARB] #I residuals +double wts[ARB] #I weight array +double userwts[ARB] #I user weight array +int npts #I number of points +real wx #I world x coordinate +real wy #I world y coordinate +int delete #I delete point + +int i, j, pmltype +real r2, r2min, x0, y0 +int gstati() + +begin + # Delete the point. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Delete or add a point. + if (delete == YES) { + + # Find the nearest undeleted point. + do i = 1, npts { + if (wts[i] <= double(0.0)) + next + call gctran (gd, real(x[i]), real(resid[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Mark the point with a cross and set weight to zero. + if (j != 0) { + call gscur (gd, real(x[j]), real(resid[j])) + call gmark (gd, real(x[j]), real(resid[j]), GM_CROSS, 2., 2.) + wts[j] = double(0.0) + } + + } else { + + # Find the nearest deleted point. + do i = 1, npts { + if (wts[i] > double(0.0)) + next + call gctran (gd, real(x[i]), real(resid[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Erase the cross and remark with a plus. + if (j != 0) { + call gscur (gd, real(x[j]), real(resid[j])) + pmltype = gstati (gd, G_PMLTYPE) + call gseti (gd, G_PMLTYPE, 0) + call gmark (gd, real(x[j]), real(resid[j]), GM_CROSS, 2., 2.) + call gseti (gd, G_PMLTYPE, pmltype) + call gmark (gd, real(x[j]), real(resid[j]), GM_PLUS, 2., 2.) + wts[j] = userwts[j] + } + } +end + + +# GEO_1GRAPH - Procedure to graph the distribution of the data in the x-y +# plane. Rejected points are marked by a ' ' and deleted points are marked +# by a ' '. The shift in position of the data points are indicated by +# vectors. Sample fits of constant x and y are marked on the plots. + +procedure geo_1graphd (gd, gt, fit, gfit, xref, yref, xin, yin, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to the geofit structure +pointer gfit #I pointer to the plot structure +double xref[ARB] #I x reference values +double yref[ARB] #I y reference values +double xin[ARB] #I x values +double yin[ARB] #I y values +double wts[ARB] #I array of weights +int npts #I number of points + +int i, j +pointer sp, rxin, ryin + +begin + # If previous plot different type don't overplot. + if (GG_PLOTTYPE(gfit) != FIT) + GG_OVERPLOT(gfit) = NO + + # If not overplottting start new plot. + if (GG_OVERPLOT(gfit) == NO) { + + # Set scale and axes. + call gclear (gd) + call smark (sp) + call salloc (rxin, npts, TY_REAL) + call salloc (ryin, npts, TY_REAL) + call achtdr (xin, Memr[rxin], npts) + call achtdr (yin, Memr[ryin], npts) + call gascale (gd, Memr[rxin], npts, 1) + call gascale (gd, Memr[ryin], npts, 2) + call sfree (sp) + call gt_swind (gd, gt) + call gtlabax (gd, gt) + + # Mark the data and deleted points. + do i = 1, npts { + if (wts[i] == double(0.0)) + call gmark (gd, real(xin[i]), real(yin[i]), GM_CROSS, + 2., 2.) + else + call gmark (gd, real(xin[i]), real(yin[i]), GM_PLUS, + 2., 2.) + } + + call gflush (gd) + } + + # Mark the rejected points. + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] + call gmark (gd, real(xin[j]), real(yin[j]), GM_CIRCLE, 2., 2.) + } + + call gflush (gd) + + # Reset the status flags + GG_OVERPLOT(gfit) = NO +end + + +# GEO_2GRAPH -- Graph the x and y fit residuals versus x or y . + +procedure geo_2graphd (gd, gt, fit, gfit, x, resid, wts, npts) + +pointer gd #I pointer to the graphics device +pointer gt #I pointer to the plot descriptor +pointer fit #I pointer to geomap structure +pointer gfit #I pointer to the plot structure +double x[ARB] #I x reference values +double resid[ARB] #I residual +double wts[ARB] #I array of weights +int npts #I number of points + +int i, j +pointer sp, zero +pointer rxin, ryin + +begin + # Allocate space. + call smark (sp) + call salloc (zero, npts, TY_REAL) + call amovkr (0.0, Memr[zero], npts) + + # Calculate the residuals. + if (GG_PLOTTYPE(gfit) == FIT) + GG_OVERPLOT(gfit) = NO + + if (GG_OVERPLOT(gfit) == NO) { + + call gclear (gd) + + # Set scale and axes. + call salloc (rxin, npts, TY_REAL) + call salloc (ryin, npts, TY_REAL) + call achtdr (x, Memr[rxin], npts) + call achtdr (resid, Memr[ryin], npts) + call gascale (gd, Memr[rxin], npts, 1) + call gascale (gd, Memr[ryin], npts, 2) + call gt_swind (gd, gt) + call gtlabax (gd, gt) + + call gpline (gd, Memr[rxin], Memr[zero], npts) + } + + # Graph residuals and mark deleted points. + if (GG_OVERPLOT(gfit) == NO || GG_NEWFUNCTION(gfit) == YES) { + do i = 1, npts { + if (wts[i] == double(0.0)) + call gmark (gd, Memr[rxin+i-1], Memr[ryin+i-1], + GM_CROSS, 2., 2.) + else + call gmark (gd, Memr[rxin+i-1], Memr[ryin+i-1], + GM_PLUS, 2., 2.) + } + } + + # plot rejected points + if (GM_NREJECT(fit) > 0) { + do i = 1, GM_NREJECT(fit) { + j = Memi[GM_REJ(fit)+i-1] + call gmark (gd, Memr[rxin+j-1], Memr[ryin+j-1], GM_CIRCLE, + 2., 2.) + } + } + + # Reset the status flag. + GG_OVERPLOT(gfit) = NO + + call gflush (gd) + call sfree (sp) +end + + +# GEO_CONXY -- Plot a set of default lines of xref = const and yref = const. + +procedure geo_conxyd (gd, fit, sx1, sy1, sx2, sy2) + +pointer gd #I graphics file descriptor +pointer fit #I fit descriptor +pointer sx1, sy1 #I pointer to the linear x and y surface fits +pointer sx2, sy2 #I pointer to the linear x and y surface fits + +int i +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +pointer xbuf, ybuf +double xint, yint, dx, dy + +begin + # allocate temporary space + call smark (sp) + call salloc (xtemp, NGRAPH, TY_DOUBLE) + call salloc (ytemp, NGRAPH, TY_DOUBLE) + call salloc (xfit1, NGRAPH, TY_DOUBLE) + call salloc (yfit1, NGRAPH, TY_DOUBLE) + call salloc (xfit2, NGRAPH, TY_DOUBLE) + call salloc (yfit2, NGRAPH, TY_DOUBLE) + call salloc (xbuf, NGRAPH, TY_REAL) + call salloc (ybuf, NGRAPH, TY_REAL) + + # Calculate intervals in x and y. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / NINTERVALS + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + + # Set up an array of y values. + Memd[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Memd[ytemp+i-1] = Memd[ytemp+i-2] + dy + + # Mark lines of constant x. + xint = GM_XMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # Set the x value. + call amovkd (xint, Memd[xtemp], NGRAPH) + + # X fit. + call dgsvector (sx1, Memd[xtemp], Memd[ytemp], Memd[xfit1], + NGRAPH) + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xtemp], Memd[ytemp], Memd[xfit2], + NGRAPH) + call aaddd (Memd[xfit1], Memd[xfit2], Memd[xfit1], NGRAPH) + } + + # Y fit. + call dgsvector (sy1, Memd[xtemp], Memd[ytemp], Memd[yfit1], + NGRAPH) + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xtemp], Memd[ytemp], Memd[yfit2], + NGRAPH) + call aaddd (Memd[yfit1], Memd[yfit2], Memd[yfit1], NGRAPH) + } + + # Plot line of constant x. + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) + + # Update the x value. + xint = xint + dx + } + + call gflush (gd) + + # Calculate x and y intervals. + dx = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + dy = (GM_YMAX(fit) - GM_YMIN(fit)) / NINTERVALS + + # Set up array of x values. + Memd[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Memd[xtemp+i-1] = Memd[xtemp+i-2] + dx + + # Mark lines of constant y. + yint = GM_YMIN(fit) + for (i = 1; i <= NINTERVALS + 1; i = i + 1) { + + # set the y value + call amovkd (yint, Memd[ytemp], NGRAPH) + + # X fit. + call dgsvector (sx1, Memd[xtemp], Memd[ytemp], Memd[xfit1], + NGRAPH) + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xtemp], Memd[ytemp], Memd[xfit2], + NGRAPH) + call aaddd (Memd[xfit1], Memd[xfit2], Memd[xfit1], NGRAPH) + } + + + # Y fit. + call dgsvector (sy1, Memd[xtemp], Memd[ytemp], Memd[yfit1], + NGRAPH) + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xtemp], Memd[ytemp], Memd[yfit2], + NGRAPH) + call aaddd (Memd[yfit1], Memd[yfit2], Memd[yfit1], NGRAPH) + } + + # Plot line of constant y. + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) + + # Update the y value. + yint = yint + dy + } + + call gflush (gd) + + call sfree (sp) +end + + +# GEO_LXY -- Draw a line of constant x-y. + +procedure geo_lxyd (gd, fit, sx1, sy1, sx2, sy2, xref, yref, xin, yin, npts, + wx, wy) + +pointer gd #I pointer to graphics descriptor +pointer fit #I pointer to the fit parameters +pointer sx1 #I pointer to the linear x fit +pointer sy1 #I pointer to the linear y fit +pointer sx2 #I pointer to the higher order x fit +pointer sy2 #I pointer to the higher order y fit +double xref[ARB] #I x reference values +double yref[ARB] #I y reference values +double xin[ARB] #I x input values +double yin[ARB] #I y input values +int npts #I number of data points +real wx, wy #I x and y world coordinates + +int i, j +pointer sp, xtemp, ytemp, xfit1, yfit1, xfit2, yfit2 +pointer xbuf, ybuf +real x0, y0, r2, r2min +double delta, deltax, deltay +double dgseval() + +begin + # Transform world coordinates. + call gctran (gd, wx, wy, wx, wy, 1, 0) + r2min = MAX_REAL + j = 0 + + # Find the nearest data point. + do i = 1, npts { + call gctran (gd, real(xin[i]), real(yin[i]), x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + j = i + } + } + + # Fit the line + if (j != 0) { + + # Allocate temporary space. + call smark (sp) + call salloc (xtemp, NGRAPH, TY_DOUBLE) + call salloc (ytemp, NGRAPH, TY_DOUBLE) + call salloc (xfit1, NGRAPH, TY_DOUBLE) + call salloc (yfit1, NGRAPH, TY_DOUBLE) + call salloc (xfit2, NGRAPH, TY_DOUBLE) + call salloc (yfit2, NGRAPH, TY_DOUBLE) + call salloc (xbuf, NGRAPH, TY_REAL) + call salloc (ybuf, NGRAPH, TY_REAL) + + # Compute the deltas. + deltax = xin[j] - dgseval (sx1, xref[j], yref[j]) + if (sx2 != NULL) + deltax = deltax - dgseval (sx2, xref[j], yref[j]) + deltay = yin[j] - dgseval (sy1, xref[j], yref[j]) + if (sy2 != NULL) + deltay = deltay - dgseval (sy2, xref[j], yref[j]) + + # Set up line of constant x. + call amovkd (xref[j], Memd[xtemp], NGRAPH) + delta = (GM_YMAX(fit) - GM_YMIN(fit)) / (NGRAPH - 1) + Memd[ytemp] = GM_YMIN(fit) + do i = 2, NGRAPH + Memd[ytemp+i-1] = Memd[ytemp+i-2] + delta + + # X solution. + call dgsvector (sx1, Memd[xtemp], Memd[ytemp], Memd[xfit1], + NGRAPH) + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xtemp], Memd[ytemp], Memd[xfit2], + NGRAPH) + call aaddd (Memd[xfit1], Memd[xfit2], Memd[xfit1], NGRAPH) + } + call aaddkd (Memd[xfit1], deltax, Memd[xfit1], NGRAPH) + + # Y solution. + call dgsvector (sy1, Memd[xtemp], Memd[ytemp], Memd[yfit1], + NGRAPH) + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xtemp], Memd[ytemp], Memd[yfit2], + NGRAPH) + call aaddd (Memd[yfit1], Memd[yfit2], Memd[yfit1], NGRAPH) + } + call aaddkd (Memd[yfit1], deltay, Memd[yfit1], NGRAPH) + + # Plot line of constant x. + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) + call gflush (gd) + + # Set up line of constant y. + call amovkd (yref[j], Memd[ytemp], NGRAPH) + delta = (GM_XMAX(fit) - GM_XMIN(fit)) / (NGRAPH - 1) + Memd[xtemp] = GM_XMIN(fit) + do i = 2, NGRAPH + Memd[xtemp+i-1] = Memd[xtemp+i-2] + delta + + # X fit. + call dgsvector (sx1, Memd[xtemp], Memd[ytemp], Memd[xfit1], + NGRAPH) + if (sx2 != NULL) { + call dgsvector (sx2, Memd[xtemp], Memd[ytemp], Memd[xfit2], + NGRAPH) + call aaddd (Memd[xfit1], Memd[xfit2], Memd[xfit1], NGRAPH) + } + call aaddkd (Memd[xfit1], deltax, Memd[xfit1], NGRAPH) + + # Y fit. + call dgsvector (sy1, Memd[xtemp], Memd[ytemp], Memd[yfit1], + NGRAPH) + if (sy2 != NULL) { + call dgsvector (sy2, Memd[xtemp], Memd[ytemp], Memd[yfit2], + NGRAPH) + call aaddd (Memd[yfit1], Memd[yfit2], Memd[yfit1], NGRAPH) + } + call aaddkd (Memd[yfit1], deltay, Memd[yfit1], NGRAPH) + + # Plot line of constant y. + call achtdr (Memd[xfit1], Memr[xbuf], NGRAPH) + call achtdr (Memd[yfit1], Memr[ybuf], NGRAPH) + call gpline (gd, Memr[xbuf], Memr[ybuf], NGRAPH) + call gflush (gd) + + # Free space. + call sfree (sp) + } +end + + +# GEO_GCOEFF -- Print the coefficents of the linear portion of the +# fit, xshift, yshift, + +procedure geo_gcoeffd (sx, sy, xshift, yshift, a, b, c, d) + +pointer sx #I pointer to the x surface fit +pointer sy #I pointer to the y surface fit +double xshift #O output x shift +double yshift #O output y shift +double a #O output x coefficient of x fit +double b #O output y coefficient of x fit +double c #O output x coefficient of y fit +double d #O output y coefficient of y fit + +int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff +pointer sp, xcoeff, ycoeff +double xxrange, xyrange, xxmaxmin, xymaxmin +double yxrange, yyrange, yxmaxmin, yymaxmin + +int dgsgeti() +double dgsgetd() + +begin + # Allocate working space. + call smark (sp) + call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_DOUBLE) + call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_DOUBLE) + + # Get coefficients and numbers of coefficients. + call dgscoeff (sx, Memd[xcoeff], nxxcoeff) + call dgscoeff (sy, Memd[ycoeff], nyycoeff) + nxxcoeff = dgsgeti (sx, GSNXCOEFF) + nxycoeff = dgsgeti (sx, GSNYCOEFF) + nyxcoeff = dgsgeti (sy, GSNXCOEFF) + nyycoeff = dgsgeti (sy, GSNYCOEFF) + + # Get the data range. + if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { + xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 + xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 + xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 + xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 + } else { + xxrange = double(1.0) + xxmaxmin = double(0.0) + xyrange = double(1.0) + xymaxmin = double(0.0) + } + + if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { + yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 + yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 + yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 + yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 + } else { + yxrange = double(1.0) + yxmaxmin = double(0.0) + yyrange = double(1.0) + yymaxmin = double(0.0) + } + + # Get the shifts. + xshift = Memd[xcoeff] + Memd[xcoeff+1] * xxmaxmin / xxrange + + Memd[xcoeff+2] * xymaxmin / xyrange + yshift = Memd[ycoeff] + Memd[ycoeff+1] * yxmaxmin / yxrange + + Memd[ycoeff+2] * yymaxmin / yyrange + + # Get the rotation and scaling parameters and correct for normalization. + if (nxxcoeff > 1) + a = Memd[xcoeff+1] / xxrange + else + a = double(0.0) + if (nxycoeff > 1) + b = Memd[xcoeff+nxxcoeff] / xyrange + else + b = double(0.0) + if (nyxcoeff > 1) + c = Memd[ycoeff+1] / yxrange + else + c = double(0.0) + if (nyycoeff > 1) + d = Memd[ycoeff+nyxcoeff] / yyrange + else + d = double(0.0) + + call sfree (sp) +end + + diff --git a/pkg/images/lib/geomap.h b/pkg/images/lib/geomap.h new file mode 100644 index 00000000..f67d64f3 --- /dev/null +++ b/pkg/images/lib/geomap.h @@ -0,0 +1,109 @@ +# Header file for GEOMAP + +define LEN_GEOMAP (54 + SZ_FNAME + SZ_LINE + 2) + +define GM_XO Memd[P2D($1)] # X origin +define GM_YO Memd[P2D($1+2)] # Y origin +define GM_ZO Memd[P2D($1+4)] # Z origin +define GM_XOREF Memd[P2D($1+6)] # X reference origin +define GM_YOREF Memd[P2D($1+8)] # Y reference origin +define GM_XMIN Memd[P2D($1+10)] # Minimum x value +define GM_XMAX Memd[P2D($1+12)] # Maximum x value +define GM_YMIN Memd[P2D($1+14)] # Minimum y value +define GM_YMAX Memd[P2D($1+16)] # Maximum y value +define GM_XOREF Memd[P2D($1+18)] # Mean of xref coords +define GM_YOREF Memd[P2D($1+20)] # Mean of yref coords +define GM_XOIN Memd[P2D($1+22)] # Mean of x coords +define GM_YOIN Memd[P2D($1+24)] # Mean of y coords +define GM_XREFPT Memd[P2D($1+26)] # Computed X reference point +define GM_YREFPT Memd[P2D($1+28)] # Computed Y reference point +define GM_XRMS Memd[P2D($1+30)] # Rms of x fit +define GM_YRMS Memd[P2D($1+32)] # Rms of y fit +define GM_REJECT Memd[P2D($1+34)] # Sigma limit for rejection +define GM_PROJECTION Memi[$1+36] # Coordinate projection type +define GM_FIT Memi[$1+37] # Fit geometry type +define GM_FUNCTION Memi[$1+38] # Function type +define GM_XXORDER Memi[$1+39] # X fit X order +define GM_XYORDER Memi[$1+40] # X fit Y order +define GM_XXTERMS Memi[$1+41] # X fit cross-terms +define GM_YXORDER Memi[$1+42] # Y fit X order +define GM_YYORDER Memi[$1+43] # Y fit Y order +define GM_YXTERMS Memi[$1+44] # Y fit cross-terms +define GM_MAXITER Memi[$1+45] # maximum number of iterations +define GM_NPTS Memi[$1+46] # Number of data points +define GM_NREJECT Memi[$1+47] # Number of rejected pixels +define GM_NWTS0 Memi[$1+48] # Number of pts with wts <= 0 +define GM_REJ Memi[$1+49] # Pointer to rejected pixels +define GM_RECORD Memc[P2C($1+50)] # Record name +define GM_PROJSTR Memc[P2C($1+50+SZ_FNAME+1)] # Projection parameters + +# geoset parameters +define GMXO 1 +define GMYO 2 +define GMXOREF 3 +define GMYOREF 4 +define GMPROJECTION 5 +define GMFIT 6 +define GMFUNCTION 7 +define GMXXORDER 8 +define GMXYORDER 9 +define GMYXORDER 10 +define GMYYORDER 11 +define GMXXTERMS 12 +define GMYXTERMS 13 +define GMREJECT 14 +define GMMAXITER 15 + +# define the permitted coordinate projections + +define GM_PROJLIST "|lin|azp|tan|sin|stg|arc|zpn|zea|air|cyp|car|\ +mer|cea|cop|cod|coe|coo|bon|pco|gls|par|ait|mol|csc|qsc|tsc|tnx|zpx|" + +define GM_NONE 0 +define GM_LIN 1 +define GM_AZP 2 +define GM_TAN 3 +define GM_SIN 4 +define GM_STG 5 +define GM_ARC 6 +define GM_ZPN 7 +define GM_ZEA 8 +define GM_AIR 9 +define GM_CYP 10 +define GM_CAR 11 +define GM_MER 12 +define GM_CEA 13 +define GM_COP 14 +define GM_COD 15 +define GM_COE 16 +define GM_COO 17 +define GM_BON 18 +define GM_PCO 19 +define GM_GLS 20 +define GM_PAR 21 +define GM_AIT 22 +define GM_MOL 23 +define GM_CSC 24 +define GM_QSC 25 +define GM_TSC 26 +define GM_TNX 27 +define GM_ZPX 28 + +# define the permitted fitting geometries + +define GM_GEOMETRIES "|shift|xyscale|rotate|rscale|rxyscale|general|" + +define GM_SHIFT 1 +define GM_XYSCALE 2 +define GM_ROTATE 3 +define GM_RSCALE 4 +define GM_RXYSCALE 5 +define GM_GENERAL 6 + +# define the permitted fitting functions + +define GM_FUNCS "|chebyshev|legendre|polynomial|" + +# define the permitted x-terms functions + +define GM_XFUNCS "|none|full|half|" diff --git a/pkg/images/lib/geomap.key b/pkg/images/lib/geomap.key new file mode 100644 index 00000000..5cc5d043 --- /dev/null +++ b/pkg/images/lib/geomap.key @@ -0,0 +1,31 @@ + Interactive Keystroke Commands + +? Print options +f Fit data and graph fit with the current graph type (g,x,r,y,s) +g Graph the data and the current fit +x,r Graph the x(in) fit residuals versus x(ref) and y(ref) respectively +y,s Graph the y(in) fit residuals versus x(ref) and y(ref) respectively +d,u Delete or undelete the data point nearest the cursor +o Overplot the next graph +c Toggle the line of constant x(ref), y(ref) plotting option +t Plot a line of constant x(ref), y(ref) through nearest data point +l Print xshift, yshift, xscale, yscale, xrotate, yrotate +q Exit the interactive surface fitting code + + Interactive Colon Commands + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +:show List parameters +:fit [value] Fit geometry (shift,xyscale,rotate,rscale,rxyscale,general) +:function [value] Fitting function (chebyshev,legendre,polynomial) +:order [value] X and Y fitting orders in x and y +:xxorder [value] X fitting function order in x +:xyorder [value] X fitting function order in y +:yxorder [value] Y fitting function order in x +:yyorder [value] Y fitting function order in y +:xxterms [n/h/f] X fit cross terms type +:yxterms [n/h/f] Y fit cross terms type +:maxiter [value] Maximum number of rejection iterations +:reject [value] K-sigma rejection threshold diff --git a/pkg/images/lib/geoset.x b/pkg/images/lib/geoset.x new file mode 100644 index 00000000..9591fa21 --- /dev/null +++ b/pkg/images/lib/geoset.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Assocation of Universities for Research in Astronomy Inc. + +include "geomap.h" + + +# GEO_SETI -- Set integer parameters. + +procedure geo_seti (fit, param, ival) + +pointer fit #I pointer to the fit structure +int param #I paramter ID +int ival #I value + +begin + switch (param) { + case GMPROJECTION: + GM_PROJECTION(fit) = ival + case GMFIT: + GM_FIT(fit) = ival + case GMFUNCTION: + GM_FUNCTION(fit) = ival + case GMXXORDER: + GM_XXORDER(fit) = ival + case GMXYORDER: + GM_XYORDER(fit) = ival + case GMYXORDER: + GM_YXORDER(fit) = ival + case GMYYORDER: + GM_YYORDER(fit) = ival + case GMXXTERMS: + GM_XXTERMS(fit) = ival + case GMYXTERMS: + GM_YXTERMS(fit) = ival + case GMMAXITER: + GM_MAXITER(fit) = ival + } +end + + +# GEO_SETD -- Set double parameters. + +procedure geo_setd (fit, param, dval) + +pointer fit #I pointer to the fit structure +int param #I paramter ID +double dval #I value + +begin + switch (param) { + case GMXO: + GM_XO(fit) = dval + case GMYO: + GM_YO(fit) = dval + case GMXOREF: + GM_XOREF(fit) = dval + case GMYOREF: + GM_YOREF(fit) = dval + case GMREJECT: + GM_REJECT(fit) = dval + } +end diff --git a/pkg/images/lib/imcopy.x b/pkg/images/lib/imcopy.x new file mode 100644 index 00000000..1d33693d --- /dev/null +++ b/pkg/images/lib/imcopy.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMG_IMCOPY -- Copy an image. Use sequential routines to permit copying +# images of any dimension. Perform pixel i/o in the datatype of the image, +# to avoid unnecessary type conversion. + +procedure img_imcopy (image1, image2, verbose) + +char image1[ARB] # Input image +char image2[ARB] # Output image +bool verbose # Print the operation + +int npix, junk +pointer buf1, buf2, im1, im2 +pointer sp, root1, root2, imtemp, section +long v1[IM_MAXDIM], v2[IM_MAXDIM] + +bool strne() +int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() + +begin + call smark (sp) + call salloc (root1, SZ_PATHNAME, TY_CHAR) + call salloc (root2, SZ_PATHNAME, TY_CHAR) + call salloc (imtemp, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + # If verbose print the operation. + if (verbose) { + call printf ("%s -> %s\n") + call pargstr (image1) + call pargstr (image2) + call flush (STDOUT) + } + + # Get the input and output root names and the output section. + call imgimage (image1, Memc[root1], SZ_PATHNAME) + call imgimage (image2, Memc[root2], SZ_PATHNAME) + call imgsection (image2, Memc[section], SZ_FNAME) + + # Map the input image. + im1 = immap (image1, READ_ONLY, 0) + + # If the output has a section appended we are writing to a + # section of an existing image. Otherwise get a temporary + # output image name and map it as a copy of the input image. + # Copy the input image to the temporary output image and unmap + # the images. Release the temporary image name. + + if (strne (Memc[root1], Memc[root2]) && Memc[section] != EOS) { + call strcpy (image2, Memc[imtemp], SZ_PATHNAME) + im2 = immap (image2, READ_WRITE, 0) + } else { + call xt_mkimtemp (image1, image2, Memc[imtemp], SZ_PATHNAME) + im2 = immap (image2, NEW_COPY, im1) + } + + # Setup start vector for sequential reads and writes. + + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + # Copy the image. + + npix = IM_LEN(im1, 1) + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + while (imgnls (im1, buf1, v1) != EOF) { + junk = impnls (im2, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + } + case TY_USHORT, TY_INT, TY_LONG: + while (imgnll (im1, buf1, v1) != EOF) { + junk = impnll (im2, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + } + case TY_REAL: + while (imgnlr (im1, buf1, v1) != EOF) { + junk = impnlr (im2, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + } + case TY_DOUBLE: + while (imgnld (im1, buf1, v1) != EOF) { + junk = impnld (im2, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + } + case TY_COMPLEX: + while (imgnlx (im1, buf1, v1) != EOF) { + junk = impnlx (im2, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + } + default: + call error (1, "unknown pixel datatype") + } + + # Unmap the images. + + call imunmap (im2) + call imunmap (im1) + call xt_delimtemp (image2, Memc[imtemp]) + call sfree (sp) +end diff --git a/pkg/images/lib/liststr.gx b/pkg/images/lib/liststr.gx new file mode 100644 index 00000000..ec627e0c --- /dev/null +++ b/pkg/images/lib/liststr.gx @@ -0,0 +1,427 @@ +include + +$for (r) + +# LI_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure li_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[ARB] #I the input buffer +int field_pos[max_fields] #O the output field positions +int max_fields #I the maximum number of fields +int nfields #O the computed number of fields + +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end + + +# LI_CAPPEND_LINE -- Fields are copied from the input buffer to the +# output buffer. + +procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, + xwidth, ywidth) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int xoffset #I the offset to the x field +int yoffset #I the offset to the y field +int xwidth #I the width of the x field +int ywidth #I the width of the y field + +int ip, op +int gstrcpy() + +begin + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add a blank. + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy the two fields. + op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, + xwidth)) + op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, + ywidth)) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS +end + +$endfor + +$for (rd) + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_num$t (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +PIXEL fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int cto$t(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = cto$t (linebuf, ip, fval) + if (nchar == 0 || fval == $INDEF$T) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +PIXEL xt #I the transformed x coordinate +PIXEL yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_field$t (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_field$t (yt, Memc[field], maxch, yformat, + nsdig_y, width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_line$t (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +PIXEL xt #I the transformed x coordinate +PIXEL yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_field$t (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_field$t (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_field$t (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +PIXEL fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call parg$t (fval) + } else { + call sprintf (wordbuf, maxch, format) + call parg$t (fval) + } +end + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_line$t (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +PIXEL values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_field$t (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], width, + min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_line$t (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +PIXEL values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call rg_qsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_field$t (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + +$endfor diff --git a/pkg/images/lib/liststr.x b/pkg/images/lib/liststr.x new file mode 100644 index 00000000..edb2903c --- /dev/null +++ b/pkg/images/lib/liststr.x @@ -0,0 +1,766 @@ +include + + + +# LI_FIND_FIELDS -- This procedure finds the starting column for each field +# in the input line. These column numbers are returned in the array +# field_pos; the number of fields is also returned. + +procedure li_find_fields (linebuf, field_pos, max_fields, nfields) + +char linebuf[ARB] #I the input buffer +int field_pos[max_fields] #O the output field positions +int max_fields #I the maximum number of fields +int nfields #O the computed number of fields + +bool in_field +int ip, field_num + +begin + field_num = 1 + field_pos[1] = 1 + in_field = false + + for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { + if (! IS_WHITE(linebuf[ip])) + in_field = true + else if (in_field) { + in_field = false + field_num = field_num + 1 + field_pos[field_num] = ip + } + } + + field_pos[field_num+1] = ip + nfields = field_num +end + + +# LI_CAPPEND_LINE -- Fields are copied from the input buffer to the +# output buffer. + +procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, + xwidth, ywidth) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int xoffset #I the offset to the x field +int yoffset #I the offset to the y field +int xwidth #I the width of the x field +int ywidth #I the width of the y field + +int ip, op +int gstrcpy() + +begin + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add a blank. + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy the two fields. + op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, + xwidth)) + op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, + ywidth)) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS +end + + + + + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_numr (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +real fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int ctor(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = ctor (linebuf, ip, fval) + if (nchar == 0 || fval == INDEFR) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_liner (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +real xt #I the transformed x coordinate +real yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_fieldr (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_fieldr (yt, Memc[field], maxch, yformat, + nsdig_y, width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_liner (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +real xt #I the transformed x coordinate +real yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_fieldr (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_fieldr (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_fieldr (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +real fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call pargr (fval) + } else { + call sprintf (wordbuf, maxch, format) + call pargr (fval) + } +end + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_liner (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +real values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_fieldr (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], width, + min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_liner (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +real values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call rg_qsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_fieldr (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + + + +# LT_GET_NUM -- The field entry is converted from character to real or double +# in preparation for the transformation. The number of significant +# digits is counted and returned as an argument; the number of chars in +# the number is returned as the function value. + +int procedure li_get_numd (linebuf, fval, nsdig) + +char linebuf[ARB] #I the input line buffer +double fval #O the output floating point value +int nsdig #O the number of significant digits + +char ch +int nchar, ip +int ctod(), stridx() + +begin + ip = 1 + nsdig = 0 + nchar = ctod (linebuf, ip, fval) + if (nchar == 0 || fval == INDEFD) + return (nchar) + + # Skip leading white space. + ip = 1 + repeat { + ch = linebuf[ip] + if (! IS_WHITE(ch)) + break + ip = ip + 1 + } + + # Count signifigant digits + for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { + if (stridx (ch, "eEdD") > 0) + break + if (IS_DIGIT (ch)) + nsdig = nsdig + 1 + ip = ip + 1 + } + + return (nchar) +end + + +# LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_pack_lined (inbuf, outbuf, maxch, field_pos, nfields, + xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, + min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int xfield #I the field number of the x coordinate column +int yfield #I the field number of the y coordinate column +double xt #I the transformed x coordinate +double yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int num_field, width, op +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + if (num_field == xfield) { + call li_format_fieldd (xt, Memc[field], maxch, xformat, + nsdig_x, width, min_sigdigits) + } else if (num_field == yfield) { + call li_format_fieldd (yt, Memc[field], maxch, yformat, + nsdig_y, width, min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_append_lined (inbuf, outbuf, maxch, xt, yt, xformat, yformat, + nsdig_x, nsdig_y, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +double xt #I the transformed x coordinate +double yt #I the transformed y coordinate +char xformat[ARB] #I the output format for the x column +char yformat[ARB] #I the output format for the y column +int nsdig_x #I the number of significant digits in x +int nsdig_y #I the number of significant digits in y +int min_sigdigits #I the minimum number of significant digits + +int ip, op +pointer sp, field +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + # Format and add the the two extra fields with a blank between. + call li_format_fieldd (xt, Memc[field], SZ_LINE, xformat, + nsdig_x, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + call li_format_fieldd (yt, Memc[field], SZ_LINE, yformat, + nsdig_y, 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + + # Add a newline. + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + outbuf[op] = EOS + + call sfree (sp) +end + + +# LI_FORMAT_FIELD -- A transformed coordinate is written into a string +# buffer. The output field is of (at least) the same width and significance +# as the input list entry. + +procedure li_format_fieldd (fval, wordbuf, maxch, format, nsdig, width, + min_sigdigits) + +double fval #I the input value to be formatted +char wordbuf[maxch] #O the output formatted string +int maxch #I the maximum length of the output string +char format[ARB] #I the output format +int nsdig #I the number of sig-digits in current value +int width #I the width of the curent field +int min_sigdigits #I the minimum number of significant digits + +int fdigits, fwidth +begin + if (format[1] == EOS) { + fdigits = max (min_sigdigits, nsdig) + fwidth = max (width, fdigits + 1) + call sprintf (wordbuf, maxch, "%*.*g") + call pargi (fwidth) + call pargi (fdigits) + call pargd (fval) + } else { + call sprintf (wordbuf, maxch, format) + call pargd (fval) + } +end + +# LI_NPACK_LINE -- Fields are packed into the outbuf buffer. Transformed +# fields are converted to strings; other fields are copied from +# the input line to output buffer. + +procedure li_npack_lined (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +double values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +bool found +int op, num_field, num_var, width +pointer sp, field +int gstrcpy() + +begin + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + + # Initialize output pointer. + op = 1 + + do num_field = 1, nfields { + width = field_pos[num_field + 1] - field_pos[num_field] + + found = false + do num_var = 1, nvalues { + if (num_field == vfields[num_var]) { + found = true + break + } + } + + if (found) { + call li_format_fieldd (values[num_var], Memc[field], + maxch, vformats[1,num_var], nsdigits[num_var], width, + min_sigdigits) + } else { + # Put "width" characters from inbuf into field + call strcpy (inbuf[field_pos[num_field]], Memc[field], width) + } + + # Fields must be delimited by at least one blank. + if (num_field > 1 && !IS_WHITE (Memc[field])) { + outbuf[op] = ' ' + op = op + 1 + } + + # Copy "field" to output buffer. + op = op + gstrcpy (Memc[field], outbuf[op], maxch) + } + + outbuf[op] = '\n' + outbuf[op+1] = EOS + + call sfree (sp) +end + + +# LI_NAPPEND_LINE -- Fields are appened to the input buffer. Transformed +# fields are converted to strings and added to the end of the input buffer. + +procedure li_nappend_lined (inbuf, outbuf, maxch, field_pos, nfields, + vfields, values, nsdigits, nvalues, vformats, sz_fmt, min_sigdigits) + +char inbuf[ARB] #I the input string buffer +char outbuf[maxch] #O the output string buffer +int maxch #I the maximum size of the output buffer +int field_pos[ARB] #I starting positions for the fields +int nfields #I the number of fields +int vfields[ARB] #I the fields to be formatted +double values[ARB] #I the field values to be formatted +int nsdigits[ARB] #I the number of field significant digits +int nvalues #I the number of fields to be formatted +char vformats[sz_fmt,ARB] #I the field formats +int sz_fmt #I the size of the format string +int min_sigdigits #I the minimum number of significant digits + +int num_var, ip, op, index +pointer sp, field, nvfields +int gstrcpy() + +begin + # Allocate some working space. + call smark (sp) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (nvfields, nvalues, TY_INT) + do num_var = 1, nvalues + Memi[nvfields+num_var-1] = num_var + call rg_qsorti (vfields, Memi[nvfields], Memi[nvfields], nvalues) + + # Copy the input buffer into the output buffer minus the newline. + op = 1 + for (ip = 1; ip <= maxch; ip = ip + 1) { + if (inbuf[ip] == '\n' || inbuf[ip] == EOS) + break + outbuf[op] = inbuf[ip] + op = op + 1 + } + + # Add two blanks. + op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) + + do num_var = 1, nvalues { + index = Memi[nvfields+num_var-1] + call li_format_fieldd (values[index], Memc[field], SZ_LINE, + vformats[sz_fmt,index], nsdigits[index], 0, min_sigdigits) + op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) + if (num_var == nvalues) { + if (op <= maxch) { + outbuf[op] = '\n' + op = op + 1 + } + } else { + if (op <= maxch) { + outbuf[op] = ' ' + op = op + 1 + } + } + } + + outbuf[op] = EOS + + call sfree (sp) +end + + + diff --git a/pkg/images/lib/mkpkg b/pkg/images/lib/mkpkg new file mode 100644 index 00000000..dd55f750 --- /dev/null +++ b/pkg/images/lib/mkpkg @@ -0,0 +1,72 @@ +# Library for the IMAGES package containing routines used by tasks in +# different subpackages + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (geofit.x,geofit.gx) + $(GEN) geofit.gx -o geofit.x $endif + $ifolder (geogmap.x,geogmap.gx) + $(GEN) geogmap.gx -o geogmap.x $endif + $ifolder (geograph.x,geograph.gx) + $(GEN) geograph.gx -o geograph.x $endif + + $ifolder (liststr.x, liststr.gx) + $(GEN) liststr.gx -o liststr.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + # used by imcopy, lineclean tasks + imcopy.x + + # used by xregister, psfmatch tasks + rgbckgrd.x + rgcontour.x \ + + rgfft.x + + # used by geoxytran and other list reading and writing tasks + liststr.x + + # geomap, ccmap, and other tasks?, should be fmtio routine which is + # the reverse of strdic + rgwrdstr.x + + # used by ccmap, ccsetwcs, cctran, skyxymatch, skyctran, imcctran + # ccxymatch tasks + # put in xtools at some point ? + #skywcs.x \ + # "skywcs.h" "skywcsdef.h" + + # used by ccmap, ccxymatch + rgccwcs.x + + # used by xyxymatch, ccxymatch, imtile tasks + rgsort.x + + # used by skyxymatch and imctran tasks, include in skywcs.x ? + rglltran.x + + # used by skyxymatch, wcsxymatch, imcctran tasks + rgxymatch.x + + # used by ccxymatch, xyxymatch tasks + rgmerge.x "xyxymatch.h" + rgtransform.x "xyxymatch.h" + xymatch.x "xyxymatch.h" + + # used by ccmap, geomap tasks + geofit.x "geomap.h" + geogmap.x "geomap.h" \ + "geogmap.h" + geograph.x \ + "geomap.h" "geogmap.h" + geoset.x "geomap.h" + ; diff --git a/pkg/images/lib/rgbckgrd.x b/pkg/images/lib/rgbckgrd.x new file mode 100644 index 00000000..feef4fd4 --- /dev/null +++ b/pkg/images/lib/rgbckgrd.x @@ -0,0 +1,661 @@ +include +include +include + + +# RG_BORDER -- Fetch the border pixels from a 2D subraster. + +int procedure rg_border (buf, nx, ny, pnx, pny, ptr) + +real buf[nx,ARB] #I the input data subraster +int nx, ny #I the dimensions of the input subraster +int pnx, pny #I the size of the data region +pointer ptr #I the pointer to the output buffer + +int j, nborder, wxborder, wyborder, index + +begin + # Compute the size of the array + nborder = nx * ny - pnx * pny + if (nborder <= 0) { + ptr = NULL + return (0) + } else if (nborder >= nx * ny) { + call malloc (ptr, nx * ny, TY_REAL) + call amovr (buf, Memr[ptr], nx * ny) + return (nx * ny) + } else + call malloc (ptr, nborder, TY_REAL) + + # Fill the array. + wxborder = (nx - pnx) / 2 + wyborder = (ny - pny) / 2 + index = ptr + do j = 1, wyborder { + call amovr (buf[1,j], Memr[index], nx) + index = index + nx + } + do j = wyborder + 1, ny - wyborder { + call amovr (buf[1,j], Memr[index], wxborder) + index = index + wxborder + call amovr (buf[nx-wxborder+1,j], Memr[index], wxborder) + index = index + wxborder + } + do j = ny - wyborder + 1, ny { + call amovr (buf[1,j], Memr[index], nx) + index = index + nx + } + + return (nborder) +end + + +# RG_SUBTRACT -- Subtract a plane from the data. + +procedure rg_subtract (data, nx, ny, zero, xslope, yslope) + +real data[nx,ARB] #I/O the input/output data array +int nx, ny #I the dimensions of the input data array +real zero #I the input zero point +real xslope #I the input x slope +real yslope #I the input y slope + +int i, j +real ydelta + +begin + do j = 1, ny { + ydelta = yslope * j + do i = 1, nx + data[i,j] = data[i,j] - zero - xslope * i - ydelta + } +end + + +# RG_APODIZE -- Apply a cosine bell to the data. The operation can be +# performed in place + +procedure rg_apodize (data, nx, ny, apodize, forward) + +real data[nx,ARB] #I the input data array +int nx, ny #I the size of the input array +real apodize #I the percentage of the end to apodize +int forward #I YES for forward, NO for reverse + +int i, j, nxpercent, nypercent, iindex, jindex +real f + +begin + nxpercent = apodize * nx + nypercent = apodize * ny + + if (forward == YES) { + do j = 1, ny { + do i = 1, nxpercent { + iindex = nx - i + 1 + f = (1.0 - cos (PI * real (i-1) / real(nxpercent))) / 2.0 + data[i,j] = f * data[i,j] + data[iindex,j] = f * data[iindex,j] + } + } + do i = 1, nx { + do j = 1, nypercent { + jindex = ny - j + 1 + f = (1.0 - cos (PI * real (j-1) / real(nypercent))) / 2.0 + data[i,j] = f * data[i,j] + data[i,jindex] = f * data[i,jindex] + } + } + } else { + do j = 1, ny { + do i = 1, nxpercent { + iindex = nx - i + 1 + f = (1.0 - cos (PI * real (i-1) / real(nxpercent))) / 2.0 + if (f < 1.0e-3) + f = 1.0e-3 + data[i,j] = data[i,j] / f + data[iindex,j] = data[iindex,j] / f + } + } + do i = 1, nx { + do j = 1, nypercent { + jindex = ny - j + 1 + f = (1.0 - cos (PI * real (j-1) / real(nypercent))) / 2.0 + if (f < 1.0e-3) + f = 1.0e-3 + data[i,j] = data[i,j] / f + data[i,jindex] = data[i,jindex] / f + } + } + } +end + + +# RG_ZNSUM -- Compute the mean and number of good points in the array with +# one optional level of rejections. + +int procedure rg_znsum (data, npts, mean, lcut, hcut) + +real data[ARB] #I the input data array +int npts #I the number of data points +real mean #O the mean of the data +real lcut, hcut #I the good data limits + +int i, ngpts +real dif, sigma, sum, sumsq, lo, hi +real asumr(), assqr() + +begin + # Get the mean. + if (npts == 0) { + mean = INDEFR + return (0) + } else if (npts == 1) { + mean = data[1] + return (1) + } else { + sum = asumr (data, npts) + mean = sum / npts + } + + # Quit if the rejection flags are not set. + if (IS_INDEFR(lcut) && IS_INDEFR(hcut)) + return (npts) + + # Compute sigma + sumsq = assqr (data, npts) + sigma = sumsq / (npts - 1) - mean * sum / (npts - 1) + if (sigma <= 0.0) + sigma = 0.0 + else + sigma = sqrt (sigma) + if (sigma <= 0.0) + return (npts) + + # Do the k-sigma rejection. + if (IS_INDEF(lcut)) + lo = -MAX_REAL + else + lo = -lcut * sigma + if (IS_INDEFR(hcut)) + hi = MAX_REAL + else + hi = hcut * sigma + + # Reject points. + ngpts = npts + do i = 1, npts { + dif = (data[i] - mean) + if (dif >= lo && dif <= hi) + next + ngpts = ngpts - 1 + sum = sum - data[i] + sumsq = sumsq - data[i] ** 2 + } + + # Get the final mean. + if (ngpts == 0) { + mean = INDEFR + return (0) + } else if (ngpts == 1) { + mean = sum + return (1) + } else + mean = sum / ngpts + + return (ngpts) +end + + +# RG_ZNMEDIAN -- Compute the median and number of good points in the array +# with one level of rejection. + +int procedure rg_znmedian (data, npts, median, lcut, hcut) + +real data[ARB] #I the input data array +int npts #I the number of data points +real median #O the median of the data +real lcut, hcut #I the good data limits + +int i, ngpts, lindex, hindex +pointer sp, sdata +real mean, sigma, dif, lo, hi +real amedr() + +begin + if (IS_INDEFR (lcut) && IS_INDEFR(hcut)) { + median = amedr (data, npts) + return (npts) + } + + # Allocate working space. + call smark (sp) + call salloc (sdata, npts, TY_REAL) + call asrtr (data, Memr[sdata], npts) + if (mod (npts, 2) == 0) + median = (Memr[sdata+(1+npts)/2-1] + Memr[sdata+(1+npts)/2]) / 2.0 + else + median = Memr[sdata+(1+npts)/2-1] + + # Compute the sigma. + call aavgr (Memr[sdata], npts, mean, sigma) + if (sigma <= 0.0) { + call sfree (sp) + return (npts) + } + + # Do rejection. + ngpts = npts + if (IS_INDEFR(lo)) + lo = -MAX_REAL + else + lo = -lcut * sigma + if (IS_INDEFR(hi)) + hi = MAX_REAL + else + hi = hcut * sigma + + do i = 1, npts { + lindex = i + dif = Memr[sdata+i-1] - median + if (dif >= lo) + break + } + do i = npts, 1, -1 { + hindex = i + dif = Memr[sdata+i-1] - median + if (dif <= hi) + break + } + + ngpts = hindex - lindex + 1 + if (ngpts <= 0) + median = INDEFR + else if (mod (ngpts, 2) == 0) + median = (Memr[sdata+lindex-1+(ngpts+1)/2-1] + Memr[sdata+lindex-1+ + (ngpts+1)/2]) / 2.0 + else + median = Memr[sdata+lindex-1+(ngpts+1)/2-1] + + call sfree (sp) + + return (ngpts) +end + + +# RG_SLOPE -- Subtract a slope from the data to be psf matched. + +int procedure rg_slope (gs, data, npts, nx, ny, wxborder, wyborder, loreject, + hireject) + +pointer gs #I the pointer to surfit structure +real data[ARB] #I/O the input/output data +int npts #I the number of points +int nx, ny #I dimensions of the original data +int wxborder, wyborder #I the x and y width of the border +real loreject, hireject #I the rejection criteria + +int i, stat, ier +pointer sp, x, y, w, zfit +real lcut, hcut, sigma +int rg_reject(), rg_breject() +real rg_sigma(), rg_bsigma() + +begin + # Initialize. + call smark (sp) + call salloc (x, nx, TY_REAL) + call salloc (y, nx, TY_REAL) + call salloc (w, nx, TY_REAL) + call salloc (zfit, nx, TY_REAL) + do i = 1, nx + Memr[x+i-1] = i + call amovkr (1.0, Memr[w], nx) + + # Accumulate the fit. + call gszero (gs) + if (npts >= nx * ny) + call rg_gsaccum (gs, Memr[x], Memr[y], Memr[w], data, nx, ny) + else + call rg_gsborder (gs, Memr[x], Memr[y], Memr[w], data, nx, ny, + wxborder, wyborder) + + # Solve the surface. + call gssolve (gs, ier) + if (ier == NO_DEG_FREEDOM) { + call sfree (sp) + return (ERR) + } + + # Perform the rejection. + if (! IS_INDEFR(loreject) || ! IS_INDEFR(hireject)) { + if (npts >= nx * ny) + sigma = rg_sigma (gs, Memr[x], Memr[y], Memr[w], Memr[zfit], + data, nx, ny) + else + sigma = rg_bsigma (gs, Memr[x], Memr[y], Memr[w], Memr[zfit], + data, nx, ny, wxborder, wyborder) + if (sigma <= 0.0) { + call sfree (sp) + return (OK) + } + if (! IS_INDEFR(loreject)) + lcut = -loreject * sigma + else + lcut = -MAX_REAL + if (! IS_INDEFR(hireject)) + hcut = hireject * sigma + else + hcut = MAX_REAL + if (npts >= nx * ny) + stat = rg_reject (gs, Memr[x], Memr[y], Memr[w], Memr[zfit], + data, nx, ny, lcut, hcut) + else + stat = rg_breject (gs, Memr[x], Memr[y], Memr[w], Memr[zfit], + data, nx, ny, wxborder, wyborder, lcut, hcut) + } + + call sfree (sp) + return (stat) +end + + +# RG_GSACCUM -- Accumulate the points into the fits assuming the data is in the +# form of a two-dimensional subraster. + +procedure rg_gsaccum (gs, x, y, w, data, nx, ny) + +pointer gs #I pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the input y array +real w[ARB] #I the input weight array +real data[ARB] #I the input data array +int nx, ny #I the size of the input data array + +int i, index + +begin + index = 1 + do i = 1, ny { + call amovkr (real (i), y, nx) + call gsacpts (gs, x, y, data[index], w, nx, WTS_USER) + index = index + nx + } +end + + +# RG_GSBORDER -- Procedure to accumulate the points into the fit assuming +# that a border has been extracted + +procedure rg_gsborder (gs, x, y, w, data, nx, ny, wxborder, wyborder) + +pointer gs #I pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the input y array +real w[ARB] #I the input weight array +real data[ARB] #I the input data array +int nx, ny #I the dimensions of the input data +int wxborder, wyborder #I the width of the border + +int i, index, nborder + +begin + nborder = nx * ny - (nx - wxborder) * (ny - wyborder) + + index = 1 + do i = 1, wyborder { + call amovkr (real (i), y, nx) + call gsacpts (gs, x, y, data[index], w, nx, WTS_USER) + index = index + nx + } + + index = nx * wyborder + 1 + do i = wyborder + 1, ny - wyborder { + call amovkr (real (i), y, nx) + call gsacpts (gs, x, y, data[index], w, wxborder, WTS_USER) + index = index + wxborder + call gsacpts (gs, x[1+nx-wxborder], y[1+nx-wxborder], + data[index], w[1+nx-wxborder], wxborder, WTS_USER) + index = index + wxborder + } + + index = 1 + nborder - nx * wyborder + do i = ny - wyborder + 1, ny { + call amovkr (real (i), y, nx) + call gsacpts (gs, x, y, data[index], w, nx, WTS_USER) + index = index + nx + } + +end + + +# RG_SIGMA -- Compute sigma assuming the data is in the form of a +# two-dimensional subraster. + +real procedure rg_sigma (gs, x, y, w, zfit, data, nx, ny) + +pointer gs #I the pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the input y array +real w[ARB] #I the input w array +real zfit[ARB] #O the output fitted data +real data[ARB] #I/O the input/output data array +int nx, ny #I the dimensions of the output data + +int i, j, index, npts +real sum + +begin + npts = 0 + index = 1 + sum = 0.0 + + do i = 1, ny { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (w[j] > 0.0) { + sum = sum + zfit[j] ** 2 + npts = npts + 1 + } + } + index = index + nx + } + + return (sqrt (sum / npts)) +end + + +# RG_BSIGMA -- Procedure to compute sigma assuming a border has been +# extracted from a subraster. + +real procedure rg_bsigma (gs, x, y, w, zfit, data, nx, ny, wxborder, wyborder) + +pointer gs #I the pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the output y array +real w[ARB] #I the output weight array +real zfit[ARB] #O the fitted z array +real data[ARB] #I/O the input/output data array +int nx, ny #I the dimensions of original subraster +int wxborder, wyborder #I the width of the border + +int i, j, npts, nborder, index +real sum + +begin + nborder = nx * ny - (nx - wxborder) * (ny - wyborder) + npts = 0 + index = 1 + sum = 0.0 + + do i = 1, wyborder { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (w[j] > 0.0) { + npts = npts + 1 + sum = sum + zfit[j] ** 2 + } + } + index = index + nx + } + + index = nx * wyborder + 1 + do i = wyborder + 1, ny - wyborder { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, wxborder) + call asubr (data[index], zfit, zfit, wxborder) + do j = 1, wxborder { + if (w[j] > 0.0) { + npts = npts + 1 + sum = sum + zfit[j] ** 2 + } + } + index = index + wxborder + call gsvector (gs, x[1+nx-wxborder], y[1+nx-wxborder], zfit, + wxborder) + call asubr (data[index], zfit, zfit, wxborder) + do j = 1, wxborder { + if (w[j] > 0.0) { + npts = npts + 1 + sum = sum + zfit[j] ** 2 + } + } + index = index + wxborder + } + + index = 1 + nborder - nx * wyborder + do i = ny - wyborder + 1, ny { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (w[j] > 0.0) { + npts = npts + 1 + sum = sum + zfit[j] ** 2 + } + } + index = index + nx + } + + return (sqrt (sum / npts)) +end + + +# RG_REJECT -- Reject points from the fit assuming the data is in the form of a +# two-dimensional subraster. + +int procedure rg_reject (gs, x, y, w, zfit, data, nx, ny, lcut, hcut) + +pointer gs #I the pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the input y array +real w[ARB] #I the input w array +real zfit[ARB] #O the fitted data +real data[ARB] #I/O the input/output data array +int nx, ny #I the dimensions of the data +real lcut, hcut #I the lo and high side rejection criteria + +int i, j, index, ier + +begin + index = 1 + + do i = 1, ny { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (zfit[j] < lcut || zfit[j] > hcut) + call gsrej (gs, x[j], y[j], data[index+j-1], w[j], WTS_USER) + } + index = index + nx + } + + call gssolve (gs, ier) + if (ier == NO_DEG_FREEDOM) + return (ERR) + else + return (OK) +end + + +# RG_BREJECT -- Reject deviant points from the fits assuming a border has +# been extracted from the subraster. + +int procedure rg_breject (gs, x, y, w, zfit, data, nx, ny, wxborder, + wyborder, lcut, hcut) + +pointer gs #I the pointer to the surface fitting structure +real x[ARB] #I the input x array +real y[ARB] #I the input y array +real w[ARB] #I the input weight array +real zfit[ARB] #O the fitted z array +real data[ARB] #I/O the input/output data array +int nx, ny #I the dimensions of the original subraster +int wxborder, wyborder #I the width of the border +real lcut, hcut #I the low and high rejection criteria + +int i, j, nborder, index, ier + +begin + nborder = nx * ny - (nx - wxborder) * (ny - wyborder) + index = 1 + + do i = 1, wyborder { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (zfit[j] < lcut || zfit[j] > hcut) + call gsrej (gs, x[j], y[j], data[index+j-1], w[j], + WTS_USER) + } + index = index + nx + } + + index = nx * wyborder + 1 + do i = wyborder + 1, ny - wyborder { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, wxborder) + call asubr (data[index], zfit, zfit, wxborder) + do j = 1, wxborder { + if (zfit[j] < lcut || zfit[j] > hcut) + call gsrej (gs, x[j], y[j], data[index+j-1], w[j], + WTS_USER) + } + index = index + wxborder + call gsvector (gs, x[1+nx-wxborder], y[1+nx-wxborder], zfit, + wxborder) + call asubr (data[index], zfit, zfit, wxborder) + do j = 1, wxborder { + if (zfit[j] < lcut || zfit[j] > hcut) + call gsrej (gs, x[j], y[j], data[index+j-1], w[j], + WTS_USER) + } + index = index + wxborder + } + + index = 1 + nborder - nx * wyborder + do i = ny - wyborder + 1, ny { + call amovkr (real (i), y, nx) + call gsvector (gs, x, y, zfit, nx) + call asubr (data[index], zfit, zfit, nx) + do j = 1, nx { + if (zfit[j] < lcut || zfit[j] > hcut) + call gsrej (gs, x[j], y[j], data[index+j-1], w[j], + WTS_USER) + } + index = index + nx + } + + call gssolve (gs, ier) + if (ier == NO_DEG_FREEDOM) + return (ERR) + else + return (OK) +end + diff --git a/pkg/images/lib/rgccwcs.x b/pkg/images/lib/rgccwcs.x new file mode 100644 index 00000000..519c2cb3 --- /dev/null +++ b/pkg/images/lib/rgccwcs.x @@ -0,0 +1,221 @@ +include +include +include +include + + +# RG_CELTOSTD - Convert the longitude / latitude coordinates to standard +# coordinates given the position of the reference point and the form of +# the projection. + +procedure rg_celtostd (projection, lngref, latref, xi, eta, npts, reflng, + reflat, lngunits, latunits) + +char projection[ARB] #I the projection type +double lngref[ARB] #I the input ra / longitude coordinates +double latref[ARB] #I the input dec / latitude coordinates +double xi[ARB] #O the output ra / longitude std coordinates +double eta[ARB] #O the output dec / latitude std coordinates +int npts #I the number of data points +double reflng #I the ra / longitude reference point +double reflat #I the dec / latitude reference point +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units + + +double tlngref, tlatref +int i +pointer mw, ct +pointer rg_projwcs(), mw_sctran() +errchk mw_sctran() + +begin + # Initialize the projection transformation. + mw = rg_projwcs (projection, reflng, reflat, lngunits, latunits) + + # Compile the transformation. + ct = mw_sctran (mw, "world", "logical", 03B) + + # Evaluate the standard coordinates. + do i = 1, npts { + + switch (lngunits) { + case SKY_DEGREES: + tlngref = lngref[i] + case SKY_RADIANS: + tlngref = RADTODEG(lngref[i]) + case SKY_HOURS: + tlngref = 15.0d0 * lngref[i] + default: + tlngref = lngref[i] + } + + switch (latunits) { + case SKY_DEGREES: + tlatref = latref[i] + case SKY_RADIANS: + tlatref = RADTODEG(latref[i]) + case SKY_HOURS: + tlatref = 15.0d0 * latref[i] + default: + tlatref = latref[i] + } + + call mw_c2trand (ct, tlngref, tlatref, xi[i], eta[i]) + } + + call mw_close (mw) + +end + + +# RG_STDTOCEL - Convert the longitude / latitude coordinates to standard +# coordinates given the position of the reference point and the form of +# the projection. + +procedure rg_stdtocel (projection, xi, eta, lngfit, latfit, npts, reflng, + reflat, lngunits, latunits) + +char projection[ARB] #I the sky projection geometry +double xi[ARB] #I the output ra / longitude std coordinates +double eta[ARB] #I the output dec / latitude std coordinates +double lngfit[ARB] #O the input ra / longitude coordinates +double latfit[ARB] #O the input dec / latitude coordinates +int npts #I the number of data points +double reflng #I the ra / longitude reference point +double reflat #I the dec / latitude reference point +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units + +double tlngref, tlatref +int i +pointer mw, ct +pointer rg_projwcs(), mw_sctran() +errchk mw_sctran() + +begin + # Initialize the projection transformation. + mw = rg_projwcs (projection, reflng, reflat, lngunits, latunits) + + # Compile the transformation. + ct = mw_sctran (mw, "logical", "world", 03B) + + # Evaluate the standard coordinates. + do i = 1, npts { + + call mw_c2trand (ct, xi[i], eta[i], tlngref, tlatref) + + switch (lngunits) { + case SKY_DEGREES: + lngfit[i] = tlngref + case SKY_RADIANS: + lngfit[i] = DEGTORAD(tlngref) + case SKY_HOURS: + lngfit[i] = tlngref / 15.0d0 + default: + lngfit[i] = tlngref + } + + switch (latunits) { + case SKY_DEGREES: + latfit[i] = tlatref + case SKY_RADIANS: + latfit[i] = DEGTORAD(tlatref) + case SKY_HOURS: + latfit[i] = tlatref / 15.0d0 + default: + latfit[i] = tlatref + } + + } + + call mw_close (mw) +end + + +# RG_PROJWCS -- Set up a projection wcs given the projection type, the +# coordinates of the reference point, and the reference point units. + +pointer procedure rg_projwcs (projection, reflng, reflat, lngunits, latunits) + +char projection[ARB] #I the projection type +double reflng #I the ra / longitude reference point +double reflat #I the dec / latitude reference point +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units + +int ndim +pointer sp, projstr, projpars, wpars, ltm, ltv, cd, r, w, mw, axes +pointer mw_open() + +begin + ndim = 2 + + # Allocate working space. + call smark (sp) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (projpars, SZ_LINE, TY_CHAR) + call salloc (wpars, SZ_LINE, TY_CHAR) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (cd, ndim * ndim, TY_DOUBLE) + call salloc (r, ndim, TY_DOUBLE) + call salloc (w, ndim, TY_DOUBLE) + call salloc (axes, IM_MAXDIM, TY_INT) + + # Open the wcs. + mw = mw_open (NULL, ndim) + + # Set the axes and projection type. + Memi[axes] = 1 + Memi[axes+1] = 2 + if (projection[1] == EOS) + call mw_swtype (mw, Memi[axes], ndim, "linear", "") + else { + call sscan (projection) + call gargwrd (Memc[projstr], SZ_FNAME) + call gargstr (Memc[projpars], SZ_LINE) + call sprintf (Memc[wpars], SZ_LINE, + "axis 1: axtype = ra %s axis 2: axtype = dec %s") + call pargstr (Memc[projpars]) + call pargstr (Memc[projpars]) + call mw_swtype (mw, Memi[axes], ndim, Memc[projstr], Memc[wpars]) + } + + + # Set the lterm. + call mw_mkidmd (Memd[ltm], ndim) + call aclrd (Memd[ltv], ndim) + call mw_sltermd (mw, Memd[ltm], Memd[ltv], ndim) + + # Set the wterm. + call mw_mkidmd (Memd[cd], ndim) + call aclrd (Memd[r], ndim) + switch (lngunits) { + case SKY_DEGREES: + Memd[w] = reflng + case SKY_RADIANS: + Memd[w] = RADTODEG(reflng) + case SKY_HOURS: + Memd[w] = 15.0d0 * reflng + default: + Memd[w] = reflng + } + switch (latunits) { + case SKY_DEGREES: + Memd[w+1] = reflat + case SKY_RADIANS: + Memd[w+1] = RADTODEG(reflat) + case SKY_HOURS: + Memd[w+1] = 15.0d0 * reflat + default: + Memd[w+1] = reflat + } + call mw_swtermd (mw, Memd[r], Memd[w], Memd[cd], ndim) + + + call sfree (sp) + + return (mw) +end + diff --git a/pkg/images/lib/rgcontour.x b/pkg/images/lib/rgcontour.x new file mode 100644 index 00000000..62ed1934 --- /dev/null +++ b/pkg/images/lib/rgcontour.x @@ -0,0 +1,475 @@ +include +include +include +include +include +include + + +define DUMMY 6 +define XCEN 0.5 +define YCEN 0.52 +define EDGE1 0.1 +define EDGE2 0.93 +define SZ_LABEL 10 +define SZ_FMT 20 + + +# RG_CONTOUR -- Produce a contour plot of a subrasteer. + +procedure rg_contour (gp, htitle, btitle, data, ncols, nlines) + +pointer gp #I pointer to graphics stream +char htitle[ARB] #I the plot header title +char btitle[ARB] #I the plot trailer title +real data[ncols,ARB] #I input data +int ncols, nlines #I dimensions of data + +bool perimeter +int tcojmp[LEN_JUMPBUF] +int epa, status, wkid +int nset, ncontours, dashpat, nhi, old_onint +int isizel, isizem, isizep, nrep, ncrt, ilab, nulbll, ioffd +int ioffm, isolid, nla, nlm, first +pointer sp, label, temp +real interval, floor, ceiling, dmin, dmax, zero, finc, ybot +real vx1, vx2, vy1, vy2, wx1, wx2, wy1, wy2 +real first_col, last_col, first_row, last_row +real xlt, ybt, side, ext, hold[5] + +extern rg_onint() + +common /tcocom/ tcojmp +common /conflg/ first +common /noaolb/ hold +common /conre4/ isizel, isizem , isizep, nrep, ncrt, ilab, nulbll, ioffd, + ext, ioffm, isolid, nla, nlm, xlt, ybt, side + +begin + # Return if the pointer is NULL. + if (gp == NULL) + return + call greactivate (gp, 0) + + # Allocate temporary space. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (temp, ncols * nlines, TY_REAL) + + # First of all, intialize conrec's block data before altering any + # parameters in common. + first = 1 + call conbd + + # Set the local variables. + zero = 0.0 + floor = INDEFR + ceiling = INDEFR + nhi = -1 + dashpat = 528 + + # Suppress the contour labelling by setting the common + # parameter "ilab" to zero. + ilab = 0 + + # User can specify either the number of contours or the contour + # interval, or let conrec pick a nice number. Set ncontours to 0 + # and encode the FINC param expected by conrec. + + ncontours = 0 + if (ncontours <= 0) { + interval = 0.0 + if (interval <= 0.0) + finc = 0 + else + finc = interval + } else + finc = - abs (ncontours) + + # Define the data limits. + + first_col = 1.0 + last_col = real (ncols) + first_row = 1.0 + last_row = real (nlines) + + # The floor and ceiling are in absolute units, but the zero shift is + # applied first, so correct the numbers for the zero shift. Zero is + # a special number for the floor and ceiling, so do not change value + # if set to zero. + + call alimr (data, ncols * nlines, dmin, dmax) + if (IS_INDEFR(floor)) + floor = dmin + floor = floor - zero + if (IS_INDEFR (ceiling)) + ceiling = dmax + ceiling = ceiling - zero + + # Make a copy of the image and contour this. + call amovr (data, Memr[temp], nlines * ncols) + + # Apply the zero point shift. + if (abs (zero) > EPSILON) + call asubkr (Memr[temp], zero, Memr[temp], ncols * nlines) + + # Open device and make contour plot. + call gopks (STDERR) + wkid = 1 + call gclear (gp) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + # Always draw the perimeter. + perimeter = true + + # The viewport can be set by the user. If not, the viewport is + # assumed to be centered on the device. In either case, the + # viewport to window mapping is established in rg_map_viewport + # and conrec's automatic mapping scheme is avoided by setting nset=1. + vx1 = 0.0 + vx2 = 0.0 + vy1 = 0.0 + vy2 = 0.0 + call rg_map_viewport (gp, ncols, nlines, vx1, vx2, vy1, vy2, false, + perimeter) + nset = 1 + + # Supress conrec's plot label generation. + ioffm = 1 + + # Install interrupt exception handler. + call zlocpr (rg_onint, epa) + call xwhen (X_INT, epa, old_onint) + + # Make the contour plot. If an interrupt occurs ZSVJMP is reeentered + # with an error status. + call zsvjmp (tcojmp, status) + if (status == OK) { + call conrec (Memr[temp], ncols, ncols, nlines, floor, ceiling, + finc, nset, nhi, -dashpat) + } else { + call gcancel (gp) + call fseti (STDOUT, F_CANCEL, OK) + } + + # Now find window and output text string title. The window is + # set to the full image coordinates for labelling. + if (perimeter) { + + call gswind (gp, first_col, last_col, first_row, last_row) + call rg_perimeter (gp) + + call ggview (gp, wx1, wx2, wy1, wy2) + call gseti (gp, G_WCS, 0) + ybot = min (wy2 + .06, 0.99) + call gtext (gp, (wx1 + wx2) / 2.0, ybot, htitle, + "h=c;v=t;f=b;s=.7") + + # Add system id banner to plot + call gseti (gp, G_CLIP, NO) + ybot = max (wy1 - 0.08, 0.01) + call gtext (gp, (wx1 + wx2) / 2.0, ybot, btitle, "h=c;v=b;s=.5") + + call sprintf (Memc[label], SZ_LINE, + "contoured from %g to %g, interval = %g") + call pargr (hold(1)) + call pargr (hold(2)) + call pargr (hold(3)) + ybot = max (wy1 - 0.06, .03) + call gtext (gp, (wx1 + wx2) / 2.0, ybot, Memc[label], + "h=c;v=b;s=.6") + } + + call gswind (gp, first_col, last_col, first_row, last_row) + call gamove (gp, last_col, last_row) + call gflush (gp) + + call gdawk (wkid) + call gclks () + + call sfree (sp) +end + + +# RG_ONINT -- Interrupt handler for the task contour. Branches back to ZSVJMP +# in the main routine to permit shutdown without an error message. + +procedure rg_onint (vex, next_handler) + +int vex #I virtual exception +int next_handler #U not used + +int tcojmp[LEN_JUMPBUF] +common /tcocom/ tcojmp + +begin + call xer_reset() + call zdojmp (tcojmp, vex) +end + + +# RG_PERIMETER -- draw and annotate the axes drawn around the perimeter +# of the image pixels. The viewport and window have been set by +# the calling procedure. Plotting is done in window coordinates. +# This procedure is called by both crtpict and the ncar plotting routines +# contour and hafton. + +procedure rg_perimeter (gp) + +pointer gp #I graphics descriptor + +real xs, xe, ys, ye +int i, first_col, last_col, first_tick, last_tick, bias +int nchar, dummy, first_row, last_row, cnt_step, cnt_label +pointer sp, label, fmt1, fmt2, fmt3, fmt4 +real dist, kk, col, row, dx, dy, sz_char, cw, xsz, label_pos +real xdist, ydist, xspace, yspace, k[3] +data k/1.0,2.0,3.0/ + +bool ggetb() +int itoc() +real ggetr() +errchk ggwind, gseti, gctran, gline, gtext, itoc + +begin + call smark (sp) + call salloc (label, SZ_LABEL, TY_CHAR) + call salloc (fmt1, SZ_FMT, TY_CHAR) + call salloc (fmt2, SZ_FMT, TY_CHAR) + call salloc (fmt3, SZ_FMT, TY_CHAR) + call salloc (fmt4, SZ_FMT, TY_CHAR) + + # First, get window coordinates and turn off clipping + call ggwind (gp, xs, xe, ys, ye) + call gseti (gp, G_CLIP, NO) + + # A readable character width seems to be about 1.mm. A readable + # perimeter seperation seems to be about .80mm. If the physical + # size of the output device is contained in the graphcap file, the + # NDC sizes of these measurements can be determined. If not, + # the separation between perimeter axes equals one quarter character + # width or one quarter percent of frame, which ever is larger, and + # the character size is set to 0.40. + + cw = max (ggetr (gp, "cw"), 0.01) + if (ggetb (gp, "xs")) { + xsz = ggetr (gp, "xs") + dist = .80 / (xsz * 1000.) + sz_char = dist / cw + } else { + # Get character width and calculate perimeter separation. + dist = cw * 0.25 + sz_char = 0.40 + } + + # Convert distance to user coordinates + call ggscale (gp, xs, ys, dx, dy) + xdist = dist * dx + ydist = dist * dy + + # Generate four possible format strings for gtext + call sprintf (Memc[fmt1], SZ_LINE, "h=c;v=t;s=%.2f") + call pargr (sz_char) + call sprintf (Memc[fmt2], SZ_LINE, "h=c;v=b;s=%.2f") + call pargr (sz_char) + call sprintf (Memc[fmt3], SZ_LINE, "h=r;v=c;s=%.2f") + call pargr (sz_char) + call sprintf (Memc[fmt4], SZ_LINE, "h=l;v=c;s=%.2f") + call pargr (sz_char) + + # Draw inner and outer perimeter + kk = k[1] + do i = 1, 2 { + xspace = kk * xdist + yspace = kk * ydist + call gline (gp, xs - xspace, ys - yspace, xe + xspace, ys - yspace) + call gline (gp, xe + xspace, ys - yspace, xe + xspace, ye + yspace) + call gline (gp, xe + xspace, ye + yspace, xs - xspace, ye + yspace) + call gline (gp, xs - xspace, ye + yspace, xs - xspace, ys - yspace) + kk = k[2] + } + + # Now draw x axis tick marks, along both the bottom and top of + # the picture. First find the endpoint integer pixels. + + first_col = int (xs) + last_col = int (xe) + + # Determine increments of ticks and tick labels for x axis + cnt_step = 1 + cnt_label = 10 + if (last_col - first_col > 256) { + cnt_step = 10 + cnt_label = 100 + } else if (last_col - first_col < 26) { + cnt_step = 1 + cnt_label = 1 + } + + first_tick = first_col + bias = mod (first_tick, cnt_step) + last_tick = last_col + bias + + do i = first_tick, last_tick, cnt_step { + col = real (i - bias) + call gline (gp, col, ys - k[1] * ydist, col, ys - k[2] * ydist) + call gline (gp, col, ye + k[1] * ydist, col, ye + k[2] * ydist) + + if (mod ((i - bias), cnt_label) == 0) { + # Label tick mark; calculate number of characters needed + nchar = 3 + if (int (col) == 0) + nchar = 1 + if (int (col) >= 1000) + nchar = 4 + + dummy = itoc (int(col), Memc[label], nchar) + + # Position label slightly below outer perimeter. Seperation + # is twenty percent of a character width, in WCS. + label_pos = ys - (k[2] * ydist + (cw * 0.20 * dy)) + call gtext (gp, col, label_pos, Memc[label], Memc[fmt1]) + + # Position label slightly above outer perimeter + label_pos = ye + (k[2] * ydist + (cw * 0.20 * dy)) + call gtext (gp, col, label_pos, Memc[label], Memc[fmt2]) + } + } + + # Label the y axis tick marks along the left and right sides of the + # picture. First find the integer pixel endpoints. + + first_row = int (ys) + last_row = int (ye) + + # Determine increments of ticks and tick labels for y axis + cnt_step = 1 + cnt_label = 10 + if (last_row - first_row > 256) { + cnt_step = 10 + cnt_label = 100 + } else if (last_row - first_row < 26) { + cnt_step = 1 + cnt_label = 1 + } + + first_tick = first_row + bias = mod (first_tick, cnt_step) + last_tick = last_row + bias + + do i = first_tick, last_tick, cnt_step { + row = real (i - bias) + call gline (gp, xs - k[1] * xdist, row, xs - k[2] * xdist, row) + call gline (gp, xe + k[1] * xdist, row, xe + k[2] * xdist, row) + + if (mod ((i - bias), cnt_label) == 0) { + # Label tick mark; calculate number of characters needed + nchar = 3 + if (int (row) == 0) + nchar = 1 + else if (int (row) >= 1000) + nchar = 4 + + dummy = itoc (int(row), Memc[label], nchar) + + # Position label slightly to the left of outer perimeter. + # Separation twenty percent of a character width, in WCS. + label_pos = xs - (k[2] * xdist + (cw * 0.20 * dx)) + call gtext (gp, label_pos, row, Memc[label], Memc[fmt3]) + + # Position label slightly to the right of outer perimeter + label_pos = xe + (k[2] * xdist + (cw * 0.20 * dx)) + call gtext (gp, label_pos, row, Memc[label], Memc[fmt4]) + } + } + + call sfree (sp) +end + + +# RG_MAP_VIEWPORT -- set device viewport for contour and hafton plots. If not +# specified by user, a default viewport centered on the device is used. + +procedure rg_map_viewport (gp, ncols, nlines, ux1, ux2, uy1, uy2, fill, + perimeter) + +pointer gp #I graphics stream descriptor +int ncols #I number of image cols +int nlines #I number of image lines +real ux1, ux2, uy1, uy2 #I/O NDC coordinates of requested viewort +bool fill #I fill viewport +bool perimeter #I draw the perimeter + +real ncolsr, nlinesr, ratio, aspect_ratio, xcen, ycen +real x1, x2, y1, y2, ext, xdis, ydis +bool fp_equalr() +real ggetr() +data ext /0.0625/ + +begin + ncolsr = real (ncols) + nlinesr = real (nlines) + + if (fp_equalr (ux1, 0.0) && fp_equalr (ux2, 0.0) && + fp_equalr (uy1, 0.0) && fp_equalr (uy2, 0.0)) { + + if (fill && ! perimeter) { + x1 = 0.0 + x2 = 1.0 + y1 = 0.0 + y2 = 1.0 + xcen = 0.5 + ycen = 0.5 + } else { + x1 = EDGE1 + x2 = EDGE2 + y1 = EDGE1 + y2 = EDGE2 + xcen = XCEN + ycen = YCEN + } + + # Calculate optimum viewport, as in NCAR's conrec, hafton + if (! fill) { + ratio = min (ncolsr, nlinesr) / max (ncolsr, nlinesr) + if (ratio >= ext) { + if (ncols > nlines) + y2 = (y2 - y1) * nlinesr / ncolsr + y1 + else + x2 = (x2 - x1) * ncolsr / nlinesr + x1 + } + } + + xdis = x2 - x1 + ydis = y2 - y1 + + # So far, the viewport has been calculated so that equal numbers of + # image pixels map to equal distances in NDC space, regardless of + # the aspect ratio of the device. If the parameter "fill" has been + # set to no, the user wants to compensate for a non-unity aspect + # ratio and make equal numbers of image pixels map to into the same + # physical distance on the device, not the same NDC distance. + + if (! fill) { + aspect_ratio = ggetr (gp, "ar") + if (fp_equalr (aspect_ratio, 0.0)) + aspect_ratio = 1.0 + if (aspect_ratio < 1.0) + xdis = xdis * aspect_ratio + else if (aspect_ratio > 1.0) + ydis = ydis / aspect_ratio + } + + ux1 = xcen - (xdis / 2.0) + ux2 = xcen + (xdis / 2.0) + uy1 = ycen - (ydis / 2.0) + uy2 = ycen + (ydis / 2.0) + } + + # Set window and viewport for WCS 1 + call gseti (gp, G_WCS, 1) + call gsview (gp, ux1, ux2, uy1, uy2) + call gswind (gp, 1.0, ncolsr, 1.0, nlinesr) + call set (ux1, ux2, uy1, uy2, 1.0, ncolsr, 1.0, nlinesr, 1) +end diff --git a/pkg/images/lib/rgfft.x b/pkg/images/lib/rgfft.x new file mode 100644 index 00000000..b986a9d7 --- /dev/null +++ b/pkg/images/lib/rgfft.x @@ -0,0 +1,269 @@ + +# RG_SZFFT -- Compute the size of the required FFT given the dimension of the +# image the window size and the fact that the FFT must be a power of 2. + +int procedure rg_szfft (npts, window) + +int npts #I the number of points in the data +int window #I the width of the valid cross correlation + +int nfft, pow2 + +begin + nfft = npts + window / 2 + + pow2 = 2 + while (pow2 < nfft) + pow2 = pow2 * 2 + + return (pow2) +end + + +# RG_RLOAD -- Procedure to load a real array into the real part of a complex +# array. + +procedure rg_rload (buf, ncols, nlines, fft, nxfft, nyfft) + +real buf[ARB] #I the input data buffer +int ncols, nlines #I the size of the input buffer +real fft[ARB] #O the out array to be fft'd +int nxfft, nyfft #I the dimensions of the fft + +int i, dindex, findex + +begin + # Load the reference and image data. + dindex = 1 + findex = 1 + do i = 1, nlines { + call rg_rweave (buf[dindex], fft[findex], ncols) + dindex = dindex + ncols + findex = findex + 2 * nxfft + } +end + + +# RG_ILOAD -- Procedure to load a real array into the complex part of a complex +# array. + +procedure rg_iload (buf, ncols, nlines, fft, nxfft, nyfft) + +real buf[ARB] #I the input data buffer +int ncols, nlines #I the size of the input buffer +real fft[ARB] #O the output array to be fft'd +int nxfft, nyfft #I the dimensions of the fft + +int i, dindex, findex + +begin + # Load the reference and image data. + dindex = 1 + findex = 1 + do i = 1, nlines { + call rg_iweave (buf[dindex], fft[findex], ncols) + dindex = dindex + ncols + findex = findex + 2 * nxfft + } +end + + +# RG_RWEAVE -- Weave a real array into the real part of a complex array. +# The output array must be twice as long as the input array. + +procedure rg_rweave (a, b, npts) + +real a[ARB] #I input array +real b[ARB] #O output array +int npts #I the number of data points + +int i + +begin + do i = 1, npts + b[2*i-1] = a[i] +end + + +# RG_IWEAVE -- Weave a real array into the complex part of a complex array. +# The output array must be twice as long as the input array. + +procedure rg_iweave (a, b, npts) + +real a[ARB] #I the input array +real b[ARB] #O the output array +int npts #I the number of data points + +int i + +begin + do i = 1, npts + b[2*i] = a[i] +end + + +# RG_FOURN -- Replaces datas by its n-dimensional discreter Fourier transform, +# if isign is input as 1. NN is an integer array of length ndim containing +# the lengths of each dimension (number of complex values), which must all +# be powers of 2. Data is a real array of length twice the product of these +# lengths, in which the data are stored as in a multidimensional complex +# Fortran array. If isign is input as -1, data is replaced by its inverse +# transform times the product of the lengths of all dimensions. + +procedure rg_fourn (data, nn, ndim, isign) + +real data[ARB] #I/O input data and output fft +int nn[ndim] #I array of dimension lengths +int ndim #I number of dimensions +int isign #I forward or inverse transform + +int idim, i1, i2, i3, ip1, ip2, ip3, ifp1, ifp2, i2rev, i3rev, k1, k2 +int ntot, nprev, n, nrem, pibit +double wr, wi, wpr, wpi, wtemp, theta +real tempr, tempi + +begin + ntot = 1 + do idim = 1, ndim + ntot = ntot * nn[idim] + + nprev = 1 + do idim = 1, ndim { + + n = nn[idim] + nrem = ntot / (n * nprev) + ip1 = 2 * nprev + ip2 = ip1 * n + ip3 = ip2 * nrem + i2rev = 1 + + do i2 = 1, ip2, ip1 { + + if (i2 < i2rev) { + do i1 = i2, i2 + ip1 - 2, 2 { + do i3 = i1, ip3, ip2 { + i3rev = i2rev + i3 - i2 + tempr = data [i3] + tempi = data[i3+1] + data[i3] = data[i3rev] + data[i3+1] = data[i3rev+1] + data[i3rev] = tempr + data[i3rev+1] = tempi + } + } + } + + pibit = ip2 / 2 + while ((pibit >= ip1) && (i2rev > pibit)) { + i2rev = i2rev - pibit + pibit = pibit / 2 + } + + i2rev = i2rev + pibit + } + + ifp1 = ip1 + while (ifp1 < ip2) { + + ifp2 = 2 * ifp1 + theta = isign * 6.28318530717959d0 / (ifp2 / ip1) + wpr = - 2.0d0 * dsin (0.5d0 * theta) ** 2 + wpi = dsin (theta) + wr = 1.0d0 + wi = 0.0d0 + + do i3 = 1, ifp1, ip1 { + do i1 = i3, i3 + ip1 - 2, 2 { + do i2 = i1, ip3, ifp2 { + k1 = i2 + k2 = k1 + ifp1 + tempr = sngl (wr) * data[k2] - sngl (wi) * + data[k2+1] + tempi = sngl (wr) * data[k2+1] + sngl (wi) * + data[k2] + data[k2] = data[k1] - tempr + data[k2+1] = data[k1+1] - tempi + data[k1] = data[k1] + tempr + data[k1+1] = data[k1+1] + tempi + } + } + wtemp = wr + wr = wr * wpr - wi * wpi + wr + wi = wi * wpr + wtemp * wpi + wi + } + + ifp1 = ifp2 + } + nprev = n * nprev + } +end + + +# RG_FSHIFT -- Center the array after doing the FFT. + +procedure rg_fshift (fft1, fft2, nx, ny) + +real fft1[nx,ARB] #I input fft array +real fft2[nx,ARB] #O output fft array +int nx, ny #I fft array dimensions + +int i, j +real fac + +begin + fac = 1.0 + do j = 1, ny { + do i = 1, nx, 2 { + fft2[i,j] = fac * fft1[i,j] + fft2[i+1,j] = fac * fft1[i+1,j] + fac = -fac + } + fac = -fac + } +end + + +# RG_MOVEXR -- Extract the portion of the FFT for which the computed lags +# are valid. The dimensions of the the FFT are a power of two +# and the 0 frequency is in the position nxfft / 2 + 1, nyfft / 2 + 1. + +procedure rg_movexr (fft, nxfft, nyfft, xcor, xwindow, ywindow) + +real fft[ARB] #I the input fft +int nxfft, nyfft #I the dimensions of the input fft +real xcor[ARB] #O the output cross-correlation function +int xwindow, ywindow #I the cross-correlation function window + +int j, ix, iy, findex, xindex + +begin + # Compute the starting index of the extraction array. + ix = 1 + nxfft - 2 * (xwindow / 2) + iy = 1 + nyfft / 2 - ywindow / 2 + + # Copy the real part of the Fourier transform into the + # cross-correlation array. + findex = ix + 2 * nxfft * (iy - 1) + xindex = 1 + do j = 1, ywindow { + call rg_extract (fft[findex], xcor[xindex], xwindow) + findex = findex + 2 * nxfft + xindex = xindex + xwindow + } +end + + +# RG_EXTRACT -- Extract the real part of a complex array. + +procedure rg_extract (a, b, npts) + +real a[ARB] #I the input array +real b[ARB] #O the output array +int npts #I the number of data points + +int i + +begin + do i = 1, npts + b[i] = a[2*i-1] +end diff --git a/pkg/images/lib/rglltran.x b/pkg/images/lib/rglltran.x new file mode 100644 index 00000000..890cec0b --- /dev/null +++ b/pkg/images/lib/rglltran.x @@ -0,0 +1,42 @@ +include +include + +# RG_LLTRANSFORM -- Transform the reference image world coordinates to the +# input image world coordinate system. + +procedure rg_lltransform (cooref, cooin, rxlng, rylat, ixlng, iylat, npts) + +pointer cooref #I pointer to the reference image coordinate structure +pointer cooin #I pointer to the input image coordinate structure +double rxlng[ARB] #I the x refererence image world coordinates (degrees) +double rylat[ARB] #I the y refererence image world coordinates (degrees) +double ixlng[ARB] #O the x refererence image world coordinates (degrees) +double iylat[ARB] #O the y refererence image world coordinates (degrees) +int npts #I the number of coordinates + +int i +double ilng, ilat, olng, olat +int sk_stati() + +begin + if (sk_stati (cooref, S_PLNGAX) < sk_stati (cooref, S_PLATAX)) { + do i = 1, npts { + ilng = DEGTORAD (rxlng[i]) + ilat = DEGTORAD (rylat[i]) + call sk_lltran (cooref, cooin, ilng, ilat, INDEFD, + INDEFD, 0.0d0, 0.0d0, olng, olat) + ixlng[i] = RADTODEG (olng) + iylat[i] = RADTODEG (olat) + } + } else { + do i = 1, npts { + ilng = DEGTORAD (rylat[i]) + ilat = DEGTORAD (rxlng[i]) + call sk_lltran (cooref, cooin, ilng, ilat, INDEFD, + INDEFD, 0.0d0, 0.0d0, olng, olat) + ixlng[i] = RADTODEG (olat) + iylat[i] = RADTODEG (olng) + } + } +end + diff --git a/pkg/images/lib/rgmerge.x b/pkg/images/lib/rgmerge.x new file mode 100644 index 00000000..5e218bd0 --- /dev/null +++ b/pkg/images/lib/rgmerge.x @@ -0,0 +1,1023 @@ +include +include +include "xyxymatch.h" + +# RG_MATCH -- Compute the intersection of two lists using a pattern matching +# algorithm. This algorithm is based on one developed by Edward Groth +# 1986 A.J. 91, 1244. The algorithm matches pairs of coordinates from +# two lists based on the triangles that can be formed from triplets of +# points in each list. The algorithm is insensitive to coordinate translation, +# rotation, magnification, or inversion and can tolerate distortions and +# random errors. + +int procedure rg_match (xref, yref, nref, xin, yin, nin, reftri, reftrirat, + nreftri, nrmaxtri, nrefstars, intri, intrirat, nintri, ninmaxtri, + nliststars, tolerance, ptolerance, ratio, nreject) + +real xref[ARB] #I the reference x coordinates +real yref[ARB] #I the reference y coordinates +int nref #I the number of reference coordinates +real xin[ARB] #I the input x coordinates +real yin[ARB] #I the input y coordinates +int nin #I the number of input coordinates +int reftri[nrmaxtri,ARB] #U list of reference triangles +real reftrirat[nrmaxtri,ARB] #U list of reference triangle parameters +int nreftri #U number of reference triangles +int nrmaxtri #I maximum number of reference triangles +int nrefstars #I the number of reference stars +int intri[ninmaxtri,ARB] #U list of input triangles +real intrirat[ninmaxtri,ARB] #U list of input triangle parameters +int nintri #U number of input triangles +int ninmaxtri #I maximum number of input triangles +int nliststars #I the number of input stars +real tolerance #I the reference triangles matching tolerance +real ptolerance #I the input triangles matching tolerance +real ratio #I the maximum ratio of triangle sides +int nreject #I maximum number of rejection iterations + +int i, nmerge, nkeep, nmatch, ncheck +pointer sp, rindex, lindex +int rg_tmerge(), rg_treject(), rg_tvote(), rg_triangle + +begin + # Match the triangles in the input list to those in the reference list. + if (nreftri < nintri) + nmerge = rg_tmerge (reftri, reftrirat, nreftri, nrmaxtri, intri, + intrirat, nintri, ninmaxtri) + else + nmerge = rg_tmerge (intri, intrirat, nintri, ninmaxtri, reftri, + reftrirat, nreftri, nrmaxtri) + if (nmerge <= 0) + return (0) + + # Perform the rejection cycle. + nkeep = rg_treject (reftri, reftrirat, nreftri, nrmaxtri, + intri, intrirat, nintri, ninmaxtri, nmerge, nreject) + if (nkeep <= 0) + return (0) + + # Match the coordinates. + nmatch = rg_tvote (reftri, nrmaxtri, nrefstars, intri, ninmaxtri, + nliststars, nkeep) + if (nmatch <= 0) + return (0) + else if (nmatch <= 3 && nkeep < nmerge) + return (0) + + # If all the coordinates were not matched then make another pass + # through the triangles matching algorithm. If the number of + # matches decreases as a result of this then all the matches were + # not true matches and declare the list unmatched. + if (nmatch < min (nref, nin) && nmatch > 2) { + + # Find the indices of the matched points. + call smark (sp) + call salloc (rindex, nmatch, TY_INT) + call salloc (lindex, nmatch, TY_INT) + do i = 1, nmatch { + Memi[rindex+i-1] = reftri[i,RG_MATCH] + Memi[lindex+i-1] = intri[i,RG_MATCH] + } + + # Recompute the triangles. + nreftri = rg_triangle (xref, yref, Memi[rindex], nmatch, reftri, + reftrirat, nrmaxtri, nrefstars, tolerance, ratio) + nintri = rg_triangle (xin, yin, Memi[lindex], nmatch, intri, + intrirat, ninmaxtri, nliststars, ptolerance, ratio) + + # Rematch the triangles. + if (nreftri < nintri) + nmerge = rg_tmerge (reftri, reftrirat, nreftri, nrmaxtri, intri, + intrirat, nintri, ninmaxtri) + else + nmerge = rg_tmerge (intri, intrirat, nintri, ninmaxtri, reftri, + reftrirat, nreftri, nrmaxtri) + + # Reperform the rejection cycle. + if (nmerge > 0) + nkeep = rg_treject (reftri, reftrirat, nreftri, nrmaxtri, + intri, intrirat, nintri, ninmaxtri, nmerge, nreject) + + # Reperform the vote. + if (nkeep > 0) { + ncheck = rg_tvote (reftri, nrmaxtri, nrefstars, intri, + ninmaxtri, nliststars, nkeep) + if (ncheck <= 3 && nkeep < nmerge) + ncheck = 0 + } else + ncheck = 0 + + if (ncheck < nmatch) + nmatch = 0 + else + nmatch = ncheck + + call sfree (sp) + } + + return (nmatch) +end + + +# RG_TRIANGLE -- Construct all the the possible triangles from +# an input coordinate list. The triangles are constructed in such a way +# that the shortest side of the triangle lies between vertices 1 and 2 and the +# longest side between vertices 1 and 3. The parameters of each triangle +# including the log of the perimeter, the ratio of the longest to shortest +# side, the cosine of the angle at vertex 1, the tolerances in the ratio +# and cosine and the sense of the triangle (clockwise or anti-clockwise) +# are also computed. Triangles with a ratio greater than maxratio are +# rejected as are triangles with vertices closer together than tolerance. + +int procedure rg_triangle (xref, yref, refindex, nrefstars, reftri, tripar, + nmaxtri, maxnpts, tolerance, maxratio) + +real xref[ARB] #I x reference coordinates +real yref[ARB] #I y reference coordinates +int refindex[ARB] #I the reference list sort index +int nrefstars #I number of reference stars +int reftri[nmaxtri,ARB] #O reference triangles +real tripar[nmaxtri,ARB] #O triangle parameters +int nmaxtri #I maximum number of triangles +int maxnpts #I the maximum number of points +real tolerance #I matching tolerance +real maxratio #I maximum ratio of triangle sides + +int i, j, k, nsample, npts, ntri +real rij, rjk, rki, dx1, dy1, dx2, dy2, dx3, dy3, r1, r2sq, r2, r3sq, r3 +real ratio, cosc, cosc2, sinc2, tol2, tol + +begin + # Create the tolerance. + tol2 = tolerance ** 2 + nsample = max (1, nrefstars / maxnpts) + npts = min (nrefstars, nsample * maxnpts) + + # Construct the triangles. + ntri = 1 + do i = 1, npts - 2 * nsample, nsample { + do j = i + nsample, npts - nsample, nsample { + do k = j + nsample, npts, nsample { + + # Compute the lengths of the three sides of the triangle, + # eliminating triangles with sides that are less than + # tolerance. + rij = (xref[refindex[i]] - xref[refindex[j]]) ** 2 + + (yref[refindex[i]] - yref[refindex[j]]) ** 2 + if (rij <= tol2) + next + rjk = (xref[refindex[j]] - xref[refindex[k]]) ** 2 + + (yref[refindex[j]] - yref[refindex[k]]) ** 2 + if (rjk <= tol2) + next + rki = (xref[refindex[k]] - xref[refindex[i]]) ** 2 + + (yref[refindex[k]] - yref[refindex[i]]) ** 2 + if (rki <= tol2) + next + + # Order the vertices with the shortest side of the triangle + # between vertices 1 and 2 and the intermediate side between + # vertices 2 and 3. + reftri[ntri,RG_INDEX] = ntri + if (rij <= rjk) { + if (rki <= rij) { + reftri[ntri,RG_X1] = refindex[k] + reftri[ntri,RG_X2] = refindex[i] + reftri[ntri,RG_X3] = refindex[j] + } else if (rki >= rjk) { + reftri[ntri,RG_X1] = refindex[i] + reftri[ntri,RG_X2] = refindex[j] + reftri[ntri,RG_X3] = refindex[k] + } else { + reftri[ntri,RG_X1] = refindex[j] + reftri[ntri,RG_X2] = refindex[i] + reftri[ntri,RG_X3] = refindex[k] + } + } else { + if (rki <= rjk) { + reftri[ntri,RG_X1] = refindex[i] + reftri[ntri,RG_X2] = refindex[k] + reftri[ntri,RG_X3] = refindex[j] + } else if (rki >= rij) { + reftri[ntri,RG_X1] = refindex[k] + reftri[ntri,RG_X2] = refindex[j] + reftri[ntri,RG_X3] = refindex[i] + } else { + reftri[ntri,RG_X1] = refindex[j] + reftri[ntri,RG_X2] = refindex[k] + reftri[ntri,RG_X3] = refindex[i] + } + } + + # Compute the lengths of the sides. + dx1 = xref[reftri[ntri,RG_X3]] - xref[reftri[ntri,RG_X2]] + dy1 = yref[reftri[ntri,RG_X3]] - yref[reftri[ntri,RG_X2]] + dx2 = xref[reftri[ntri,RG_X2]] - xref[reftri[ntri,RG_X1]] + dy2 = yref[reftri[ntri,RG_X2]] - yref[reftri[ntri,RG_X1]] + dx3 = xref[reftri[ntri,RG_X3]] - xref[reftri[ntri,RG_X1]] + dy3 = yref[reftri[ntri,RG_X3]] - yref[reftri[ntri,RG_X1]] + + # Compute the ratio of the longest side of the triangle + # to the shortest side. + r1 = sqrt (dx1 ** 2 + dy1 ** 2) + r2sq = dx2 ** 2 + dy2 ** 2 + r2 = sqrt (r2sq) + r3sq = dx3 ** 2 + dy3 ** 2 + r3 = sqrt (r3sq) + if (r2 <= 0.) + next + ratio = r3 / r2 + if (ratio > maxratio) + next + + # Compute the cos, cos ** 2 and sin ** 2 of the angle at + # vertex 1. + cosc = (dx3 * dx2 + dy3 * dy2) / (r3 * r2) + cosc2 = max (0.0, min (1.0, cosc * cosc)) + sinc2 = max (0.0, min (1.0, 1.0 - cosc2)) + + # Determine whether the triangles vertices are arranged + # clockwise of anticlockwise. + if ((dx2 * dy1 - dy2 * dx1) > 0.0) + reftri[ntri,RG_CC] = YES + else + reftri[ntri,RG_CC] = NO + + # Compute the tolerances. + tol = (1.0 / r3sq - cosc / (r3 * r2) + 1.0 / r2sq) + tripar[ntri,RG_TOLR] = 2.0 * ratio ** 2 * tol2 * tol + tripar[ntri,RG_TOLC] = 2.0 * sinc2 * tol2 * tol + 3.0 * + cosc2 * tol2 ** 2 * tol * tol + + # Compute the perimeter. + tripar[ntri,RG_LOGP] = log (r1 + r2 + r3) + tripar[ntri,RG_RATIO] = ratio + tripar[ntri,RG_COS1] = cosc + + ntri = ntri + 1 + } + } + } + + ntri = ntri - 1 + + # Sort the triangles in increasing order of ratio. + call rg_qsortr (tripar[1,RG_RATIO], reftri[1,RG_INDEX], + reftri[1,RG_INDEX], ntri) + + return (ntri) +end + + +# RG_TMERGE -- Compute the intersection of two sorted files of triangles +# using the tolerance parameter. + +int procedure rg_tmerge (reftri, rtripar, nrtri, nmrtri, listri, ltripar, + nltri, nmltri) + +int reftri[nmrtri,ARB] #U list of reference triangles +real rtripar[nmrtri,ARB] #I reference triangle parameters +int nrtri #I number of reference triangles +int nmrtri #I maximum number of reference triangles +int listri[nmltri,ARB] #U list of reference triangles +real ltripar[nmltri,ARB] #I reference triangle parameters +int nltri #I number of reference triangles +int nmltri #I maximum number of reference triangles + +int rp, blp, lp, ninter, rindex, lindex, mindex +real rmaxtol, lmaxtol, maxtol, dr, dr2, mdr2, dcos2, mdcos2, dtolr, dtolc + +begin + # Find the maximum tolerance for each list. + call alimr (rtripar[1,RG_TOLR], nrtri, maxtol, rmaxtol) + call alimr (ltripar[1,RG_TOLR], nltri, maxtol, lmaxtol) + maxtol = sqrt (rmaxtol + lmaxtol) + + # Define the beginning of the search range for each triangle. + blp = 1 + + # Loop over all the triangles in the reference list. + ninter = 0 + for (rp = 1; rp <= nrtri; rp = rp + 1) { + + # Get the index for the reference triangle. + rindex = reftri[rp,RG_INDEX] + + # Move to the first triangle in the input list that satisfies the + # ratio tolerance requirement. + for (; blp <= nltri; blp = blp + 1) { + lindex = listri[blp,RG_INDEX] + dr = rtripar[rindex,RG_RATIO] - ltripar[lindex,RG_RATIO] + if (dr <= maxtol) + break + } + + # If the beginning of the search range becomes greater than + # the length of the list then there is no match. + if (blp > nltri) + break + + # If the first triangle in the list is past the tolerance + # limit skip to the next reference triangle + if (dr < -maxtol) + next + + # Search through the appropriate range of triangles for the + # closest fit. + + # Initialize the tolerances. + mindex = 0 + mdr2 = 0.5 * MAX_REAL + mdcos2 = 0.5 * MAX_REAL + + for (lp = blp; lp <= nltri; lp = lp + 1) { + + # Quit the loop if the next triangle is out of match range. + lindex = listri[lp,RG_INDEX] + dr = rtripar[rindex,RG_RATIO] - ltripar[lindex,RG_RATIO] + if (dr < -maxtol) + break + + # Compute the tolerances for the two triangles. + dr2 = dr * dr + dcos2 = (rtripar[rindex,RG_COS1] - ltripar[lindex,RG_COS1]) ** 2 + dtolr = rtripar[rindex,RG_TOLR] + ltripar[lindex,RG_TOLR] + dtolc = rtripar[rindex,RG_TOLC] + ltripar[lindex,RG_TOLC] + + # Find the best of all possible matches. + if (dr2 <= dtolr && dcos2 <= dtolc) { + if ((dr2 + dcos2) < (mdr2 + mdcos2)) { + mindex = lindex + mdr2 = dr2 + mdcos2 = dcos2 + } + } + + } + + # Add the match to the list. + if (mindex > 0) { + ninter = ninter + 1 + reftri[ninter,RG_MATCH] = rindex + listri[ninter,RG_MATCH] = mindex + } + } + + return (ninter) +end + + +# RG_TREJECT -- Remove false matches from the list of matched triangles. + +int procedure rg_treject (reftri, rtripar, nrtri, nmrtri, listri, ltripar, + nltri, nmltri, nmatch, maxiter) + +int reftri[nmrtri,ARB] #U list of reference triangles +real rtripar[nmrtri,ARB] #I reference triangle parameters +int nrtri #I number of reference triangles +int nmrtri #I maximum number of reference triangles +int listri[nmltri,ARB] #U list of reference triangles +real ltripar[nmltri,ARB] #I reference triangle parameters +int nltri #I number of reference triangles +int nmltri #I maximum number of reference triangles +int nmatch #I initial number of matches +int maxiter #I maximum number of rejection iterations + +double dif, mode, sum, sumsq +int i, nrej, nplus, nminus, ntrue, nfalse, npts, ncount, niter, rindex +int lindex +pointer sp, adif +real sigma, factor, locut, hicut +double rg_moded() + +begin + call smark (sp) + call salloc (adif, nmatch, TY_DOUBLE) + + # Accumulate the number of same sense and number of opposite sense + # matches as well as the log perimeter statistics. + sum = 0.0d0 + sumsq = 0.0d0 + nplus = 0 + do i = 1, nmatch { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + dif = (rtripar[rindex,RG_LOGP] - ltripar[lindex,RG_LOGP]) + Memd[adif+i-1] = dif + sum = sum + dif + sumsq = sumsq + dif * dif + if (reftri[rindex,RG_CC] == listri[lindex,RG_CC]) + nplus = nplus + 1 + } + nminus = nmatch - nplus + + # Compute the mean, mode, and sigma of the logP distribution, + ntrue = abs (nplus - nminus) + nfalse = nplus + nminus - ntrue + #mean = sum / nmatch + if (nmatch <= 1) + sigma = 0.0 + else + sigma = (sumsq - (sum / nmatch) * sum) / (nmatch - 1) + if (sigma <= 0.0) { + call sfree (sp) + return (nmatch) + } else + sigma = sqrt (sigma) + call asrtd (Memd[adif], Memd[adif], nmatch) + #if (mod (nmatch,2) == 1) + #median = Memd[adif+nmatch/2] + #else + #median = (Memd[adif+nmatch/2] + Memd[adif+(nmatch-1)/2]) / 2.0d0 + mode = rg_moded (Memd[adif], nmatch, 10, 1.0d0, 0.1d0 * sigma, + 0.01d0 * sigma) + if (nfalse > ntrue) + factor = 1.0 + else if ((0.1 * ntrue) > nfalse) + factor = 3.0 + else + factor = 2.0 + + # Begin the rejection cycle. + npts = nmatch + niter = 0 + repeat { + + ncount = 0 + nrej = 0 + locut = mode - factor * sigma + hicut = mode + factor * sigma + + # Reject matched triangles which are too far from the mean logP. + do i = 1, npts { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + dif = rtripar[rindex,RG_LOGP] - ltripar[lindex,RG_LOGP] + if (dif < locut || dif > hicut) { + sum = sum - dif + sumsq = sumsq - dif * dif + if (reftri[rindex,RG_CC] == listri[lindex,RG_CC]) + nplus = nplus - 1 + else + nminus = nminus - 1 + nrej = nrej + 1 + } else { + Memd[adif+ncount] = dif + ncount = ncount + 1 + reftri[ncount,RG_MATCH] = rindex + listri[ncount,RG_MATCH] = lindex + } + } + + # No more points were rejected. + npts = ncount + if (nrej <= 0) + break + + # All the points were rejected. + if (npts <= 0) + break + + # The rejection iteration limit was reached. + niter = niter + 1 + if (niter >= maxiter) + break + + # Compute the new mean and sigma of the logP distribution. + #mean = sum / npts + if (npts <= 1) + sigma = 0.0 + else + sigma = (sumsq - (sum / npts) * sum) / (npts - 1) + if (sigma <= 0.0) + break + sigma = sqrt (sigma) + call asrtd (Memd[adif], Memd[adif], npts) + #if (mod (npts,2) == 1) + #median = Memd[adif+npts/2] + #else + #median = (Memd[adif+npts/2] + Memd[adif+(npts-1)/2]) / 2.0d0 + mode = rg_moded (Memd[adif], npts, 10, 1.0d0, 0.10d0 * sigma, + 0.01d0 * sigma) + + # Recompute the ksigma rejection criterion based on the number of + # same and opposite sense matches. + ntrue = abs (nplus - nminus) + nfalse = nplus + nminus - ntrue + if (nfalse > ntrue) + factor = 1.0 + else if ((0.1 * ntrue) > nfalse) + factor = 3.0 + else + factor = 2.0 + } + + # One last iteration to get rid of opposite sense of matches. + if (npts <= 0) + npts = 0 + else if (nplus > nminus) { + ncount = 0 + do i = 1, npts { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + if (reftri[rindex,RG_CC] == listri[lindex,RG_CC]) { + ncount = ncount + 1 + reftri[ncount,RG_MATCH] = rindex + listri[ncount,RG_MATCH] = lindex + } + } + npts = ncount + } else { + ncount = 0 + do i = 1, npts { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + if (reftri[rindex,RG_CC] != listri[lindex,RG_CC]) { + ncount = ncount + 1 + reftri[ncount,RG_MATCH] = rindex + listri[ncount,RG_MATCH] = lindex + } + } + npts = ncount + } + + call sfree (sp) + return (npts) +end + + +# RG_TVOTE -- Count the number a times a particular pair of +# coordinates is matched in the set of matched triangles. If a particular +# pair of points occurs in many triangles it is much more likely to be +# a true match than if it occurs in very few. Since this vote array +# may be quite sparsely occupied, use the PLIO package to store and +# maintain the list. + +int procedure rg_tvote (reftri, nmrtri, nrefstars, listri, nmltri, nliststars, + nmatch) + +int reftri[nmrtri,ARB] #U reference triangles +int nmrtri #I maximum number of reference triangles +int nrefstars #I number of reference stars +int listri[nmltri,ARB] #U input list triangles +int nmltri #I maximum number of list triangles +int nliststars #I number of list stars +int nmatch #I number of match triangles + +int i, j, rp, lp, vp, pixval, tminvote, tmaxvote, minvote, maxvote, hmaxvote +int ninter, axes[2], laxes[2], pvp +pointer sp, vote, vindex, pl, lmatch, rmatch +bool pl_linenotempty() +pointer pl_create() + +begin + # Open the pixel list. + axes[1] = nliststars + axes[2] = nrefstars + pl = pl_create (2, axes, 16) + + # Acumulate the votes. + do i = 1, nmatch { + rp = reftri[i,RG_MATCH] + lp = listri[i,RG_MATCH] + laxes[1] = listri[lp,RG_X1] + laxes[2] = reftri[rp,RG_X1] + if (! pl_linenotempty (pl, laxes)) + call pl_point (pl, laxes[1], laxes[2], PIX_SET + PIX_VALUE(1)) + else { + call pl_glpi (pl, laxes, pixval, 16, 1, PIX_SRC) + pixval = pixval + 1 + call pl_point (pl, laxes[1], laxes[2], PIX_SET + + PIX_VALUE(pixval)) + } + laxes[1] = listri[lp,RG_X2] + laxes[2] = reftri[rp,RG_X2] + if (! pl_linenotempty (pl, laxes)) + call pl_point (pl, laxes[1], laxes[2], PIX_SET + PIX_VALUE(1)) + else { + call pl_glpi (pl, laxes, pixval, 16, 1, PIX_SRC) + pixval = pixval + 1 + call pl_point (pl, laxes[1], laxes[2], PIX_SET + + PIX_VALUE(pixval)) + } + laxes[1] = listri[lp,RG_X3] + laxes[2] = reftri[rp,RG_X3] + if (! pl_linenotempty (pl, laxes)) + call pl_point (pl, laxes[1], laxes[2], PIX_SET + PIX_VALUE(1)) + else { + call pl_glpi (pl, laxes, pixval, 16, 1, PIX_SRC) + pixval = pixval + 1 + call pl_point (pl, laxes[1], laxes[2], PIX_SET + + PIX_VALUE(pixval)) + } + } + + # Allocate temporary working space. + call smark (sp) + call salloc (vote, axes[1], TY_INT) + call salloc (vindex, axes[1], TY_INT) + call salloc (lmatch, axes[1], TY_INT) + call salloc (rmatch, axes[2], TY_INT) + call amovki (NO, Memi[lmatch], axes[1]) + call amovki (NO, Memi[rmatch], axes[2]) + + # Find the maximum value in the mask. + minvote = MAX_INT + maxvote = -MAX_INT + do i = 1, axes[2] { + laxes[1] = 1 + laxes[2] = i + if (! pl_linenotempty (pl, laxes)) + next + call pl_glpi (pl, laxes, Memi[vote], 16, axes[1], PIX_SRC) + call alimi (Memi[vote], axes[1], tminvote, tmaxvote) + minvote = min (minvote, tminvote) + maxvote = max (maxvote, tmaxvote) + } + if (maxvote < 0) { + maxvote = 0 + hmaxvote = 0 + } else + hmaxvote = maxvote / 2 + + # Vote on the matched pairs. + ninter = 0 + if (maxvote > 0) { + do j = 1, axes[2] { + + # Sort the vote array. + do i = 1, axes[1] + Memi[vindex+i-1] = i + laxes[1] = 1 + laxes[2] = j + call pl_glpi (pl, laxes, Memi[vote], 16, axes[1], PIX_SRC) + call rg_qsorti (Memi[vote], Memi[vindex], Memi[vindex], + axes[1]) + + # Reject points which have no votes, which have only a + # single vote if the maximum number of votest is > 1, + # less or equal to half the maximum number of votes, + # the same number of votes as the next largest index, + # or which have already been matched. + + vp = Memi[vindex+axes[1]-1] + pvp = Memi[vindex+axes[1]-2] + if (Memi[vote+vp-1] <= 0) + next + if (Memi[vote+vp-1] == Memi[vote+pvp-1]) + next + if (Memi[vote+vp-1] <= hmaxvote) + next + if (Memi[lmatch+vp-1] == YES || Memi[rmatch+j-1] == YES) + next + if (Memi[vote+vp-1] == 1 && (maxvote > 1 || nmatch > 1)) + next + + ninter = ninter + 1 + reftri[ninter, RG_MATCH] = j + listri[ninter,RG_MATCH] = vp + Memi[rmatch+j-1] = YES + Memi[lmatch+vp-1] = YES + } + } else if (maxvote > 0) { + } + + call sfree (sp) + call pl_close (pl) + + return (ninter) +end + + +# RG_MLINCOEFF -- Compute the coefficients of a new linear transformation +# using the first one to three matched stars as input. + +int procedure rg_mlincoeff (xref, yref, xlist, ylist, reftri, nmrtri, listri, + nmltri, nmatch, coeff, ncoeff) + +real xref[ARB] #I the x reference coordinates +real yref[ARB] #I the y reference coordinates +real xlist[ARB] #I the x list coordinates +real ylist[ARB] #I the y list coordinates +int reftri[nmrtri,ARB] #I list of reference triangles +int nmrtri #I maximum number of reference triangles +int listri[nmltri,ARB] #I list of reference triangles +int nmltri #I maximum number of list triangles +int nmatch #I number of matches +real coeff[ARB] #O the new computed coefficients +int ncoeff #I the number of coefficients + +int i, rindex, lindex, stat +pointer sp, xr, yr, xin, yin +int rg_lincoeff() + +begin + if (nmatch <= 0) + return (ERR) + + call smark (sp) + call salloc (xr, nmatch, TY_REAL) + call salloc (yr, nmatch, TY_REAL) + call salloc (xin, nmatch, TY_REAL) + call salloc (yin, nmatch, TY_REAL) + + # Load the points to be fit. + do i = 1, nmatch { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + Memr[xr+i-1] = xref[rindex] + Memr[yr+i-1] = yref[rindex] + Memr[xin+i-1] = xlist[lindex] + Memr[yin+i-1] = ylist[lindex] + } + + # Compute the new coefficients. + stat = rg_lincoeff (Memr[xr], Memr[yr], Memr[xin], Memr[yin], + nmatch, coeff, ncoeff) + + call sfree (sp) + + return (stat) +end + + +# RG_MWRITE -- Write out the intersection of the two matched pixel lists to the +# output file. + +procedure rg_mwrite (ofd, xref, yref, rlineno, xlist, ylist, ilineno, + reftri, nmrtri, listri, nmltri, nmatch, xformat, yformat) + +int ofd #I the output file descriptor +real xref[ARB] #I the x reference coordinates +real yref[ARB] #I the y reference coordinates +int rlineno[ARB] #I the reference coordinate line numbers +real xlist[ARB] #I the x list coordinates +real ylist[ARB] #I the y list coordinates +int ilineno[ARB] #I the input list line numbers +int reftri[nmrtri,ARB] #I list of reference triangles +int nmrtri #I maximum number of reference triangles +int listri[nmltri,ARB] #I list of reference triangles +int nmltri #I maximum number of list triangles +int nmatch #I number of matches +char xformat[ARB] #I the output x column format +char yformat[ARB] #I the output y column format + +int i, lindex, rindex +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Construct the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %%5d %%5d\n") + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + + do i = 1, nmatch { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + call fprintf (ofd, Memc[fmtstr]) + call pargr (xref[rindex]) + call pargr (yref[rindex]) + call pargr (xlist[lindex]) + call pargr (ylist[lindex]) + call pargi (rlineno[rindex]) + call pargi (ilineno[lindex]) + } + + call sfree (sp) +end + + +# RG_LMWRITE -- Write out the intersection of the matched celestial coordinate +# and pixel lists to the output file. + +procedure rg_lmwrite (ofd, lngref, latref, rlineno, xlist, ylist, ilineno, + reftri, nmrtri, listri, nmltri, nmatch, lngformat, latformat, + xformat, yformat) + +int ofd #I the output file descriptor +double lngref[ARB] #I the x reference coordinates +double latref[ARB] #I the y reference coordinates +int rlineno[ARB] #I the reference coordinate line numbers +real xlist[ARB] #I the x list coordinates +real ylist[ARB] #I the y list coordinates +int ilineno[ARB] #I the input list line numbers +int reftri[nmrtri,ARB] #I list of reference triangles +int nmrtri #I maximum number of reference triangles +int listri[nmltri,ARB] #I list of reference triangles +int nmltri #I maximum number of list triangles +int nmatch #I number of matches +char lngformat[ARB] #I the output longitude column format +char latformat[ARB] #I the output latitude column format +char xformat[ARB] #I the output x column format +char yformat[ARB] #I the output y column format + +int i, lindex, rindex +pointer sp, fmtstr + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Construct the format string. + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %%5d %%5d\n") + if (lngformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (lngformat) + if (latformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (latformat) + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + + do i = 1, nmatch { + rindex = reftri[i,RG_MATCH] + lindex = listri[i,RG_MATCH] + call fprintf (ofd, Memc[fmtstr]) + call pargd (lngref[rindex]) + call pargd (latref[rindex]) + call pargr (xlist[lindex]) + call pargr (ylist[lindex]) + call pargi (rlineno[rindex]) + call pargi (ilineno[lindex]) + } + + call sfree (sp) +end + + +# RG_FACTORIAL -- Compute the combinatorial function which is defined as +# n! / ((n - ngroup)! * ngroup!). + +int procedure rg_factorial (n, ngroup) + +int n #I input argument +int ngroup #I combinatorial factor + +int i, fac, grfac + +begin + if (n <= 0) + return (1) + + fac = n + do i = n - 1, n - 3 + 1, -1 + fac = fac * i + + grfac = ngroup + do i = ngroup - 1, 2, -1 + grfac = grfac * i + + return (fac / grfac) +end + + +# RG_MODED -- Compute mode of an array. The mode is found by binning +# with a bin size based on the data range over a fraction of the +# pixels about the median and a bin step which may be smaller than the +# bin size. If there are too few points the median is returned. +# The input array must be sorted. + +double procedure rg_moded (a, npts, nmin, zrange, fzbin, fzstep) + +double a[npts] #I the sorted input data array +int npts #I the number of points +int nmin #I the minimum number of points +double zrange #I fraction of pixels around median to use +double fzbin #I the bin size for the mode search +double fzstep #I the step size for the mode search + +int x1, x2, x3, nmax +double zstep, zbin, y1, y2, mode +bool fp_equald() + +begin + # If there are too few points return the median. + if (npts < nmin) { + if (mod (npts,2) == 1) + return (a[1+npts/2]) + else + return ((a[npts/2] + a[1+npts/2]) / 2.0d0) + } + + # Compute the data range that will be used to do the mode search. + # If the data has no range then the constant value will be returned. + x1 = max (1, int (1.0d0 + npts * (1.0d0 - zrange) / 2.0d0)) + x3 = min (npts, int (1.0d0 + npts * (1.0d0 + zrange) / 2.0d0)) + if (fp_equald (a[x1], a[x3])) + return (a[x1]) + + + # Compute the bin and step size. The bin size is based on the + # data range over a fraction of the pixels around the median + # and a bin step which may be smaller than the bin size. + + zstep = fzstep #* (a[x3] - a[x1]) + zbin = fzbin #* (a[x3] - a[x1]) + + nmax = 0 + x2 = x1 + for (y1 = a[x1]; x2 < x3; y1 = y1 + zstep) { + for (; a[x1] < y1; x1 = x1 + 1) + ; + y2 = y1 + zbin + for (; (x2 < x3) && (a[x2] < y2); x2 = x2 + 1) + ; + if (x2 - x1 > nmax) { + nmax = x2 - x1 + if (mod (x2+x1,2) == 0) + mode = a[(x2+x1)/2] + else + mode = (a[(x2+x1)/2] + a[(x2+x1)/2+1]) / 2.0d0 + } + } + + return (mode) +end + + +#define NMIN 10 # Minimum number of pixels for mode calculation +#define ZRANGE 0.8d0 # Fraction of pixels about median to use +#define ZSTEP 0.01d0 # Step size for search for mode +#define ZBIN 0.1d0 # Bin size for mode. +# +## RG_MODED -- Compute mode of an array. The mode is found by binning +## with a bin size based on the data range over a fraction of the +## pixels about the median and a bin step which may be smaller than the +## bin size. If there are too few points the median is returned. +## The input array must be sorted. +# +#double procedure rg_moded (a, n) +# +#double a[n] # Data array +#int n # Number of points +# +#int i, j, k, nmax +#real z1, z2, zstep, zbin +#double mode +#bool fp_equald() +# +#begin +# if (n < NMIN) +# return (a[n/2]) +# +# # Compute the mode. The array must be sorted. Consider a +# # range of values about the median point. Use a bin size which +# # is ZBIN of the range. Step the bin limits in ZSTEP fraction of +# # the bin size. +# +# i = 1 + n * (1. - ZRANGE) / 2.0d0 +# j = 1 + n * (1. + ZRANGE) / 2.0d0 +# z1 = a[i] +# z2 = a[j] +# if (fp_equald (z1, z2)) { +# mode = z1 +# return (mode) +# } +# +# zstep = ZSTEP * (z2 - z1) +# zbin = ZBIN * (z2 - z1) +# +# z1 = z1 - zstep +# k = i +# nmax = 0 +# repeat { +# z1 = z1 + zstep +# z2 = z1 + zbin +# for (; i < j && a[i] < z1; i=i+1) +# ; +# for (; k < j && a[k] < z2; k=k+1) +# ; +# if (k - i > nmax) { +# nmax = k - i +# mode = a[(i+k)/2] +# } +# } until (k >= j) +# +# return (mode) +#end +# diff --git a/pkg/images/lib/rgsort.x b/pkg/images/lib/rgsort.x new file mode 100644 index 00000000..afaab085 --- /dev/null +++ b/pkg/images/lib/rgsort.x @@ -0,0 +1,162 @@ + +define LOGPTR 20 # log2(maxpts) (1e6) + +# RG_QSORTR -- Vector quicksort a real array. In this version the index array +# is sorted not the data array. The input and output index arrays may be the +# same. + +procedure rg_qsortr (data, a, b, npix) + +real data[ARB] #I the input data array +int a[ARB] #I the input index array +int b[ARB] #O the output index array +int npix #I the number of pixels + +int i, j, lv[LOGPTR], p, uv[LOGPTR], temp +real pivot + +begin + # Initialize the indices for an inplace sort. + call amovi (a, b, npix) + + p = 1 + lv[1] = 1 + uv[1] = npix + while (p > 0) { + + # If only one elem in subset pop stack otherwise pivot line. + if (lv[p] >= uv[p]) + p = p - 1 + else { + i = lv[p] - 1 + j = uv[p] + pivot = data[b[j]] + + while (i < j) { + for (i=i+1; data[b[i]] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (data[b[j]] <= pivot) + break + if (i < j) { # out of order pair + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + } + } + + j = uv[p] # move pivot to position i + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + p = p + 1 # push onto stack + } + } +end + + +# RG_QSORTI -- Vector quicksort an integer array. In this version the index +# array is actually sorted not the data array. The input and output index +# arrays may be the same. + +procedure rg_qsorti (data, a, b, npix) + +int data[ARB] # data array +int a[ARB] # input index array +int b[ARB] # output index array +int npix # number of pixels + +int i, j, lv[LOGPTR], p, uv[LOGPTR], temp, pivot + +begin + # Initialize the indices for an inplace sort. + call amovi (a, b, npix) + + p = 1 + lv[1] = 1 + uv[1] = npix + while (p > 0) { + + # If only one elem in subset pop stack otherwise pivot line. + if (lv[p] >= uv[p]) + p = p - 1 + else { + i = lv[p] - 1 + j = uv[p] + pivot = data[b[j]] + + while (i < j) { + for (i=i+1; data[b[i]] < pivot; i=i+1) + ; + for (j=j-1; j > i; j=j-1) + if (data[b[j]] <= pivot) + break + if (i < j) { # out of order pair + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + } + } + + j = uv[p] # move pivot to position i + temp = b[j] # interchange elements + b[j] = b[i] + b[i] = temp + + if (i-lv[p] < uv[p] - i) { # stack so shorter done first + lv[p+1] = lv[p] + uv[p+1] = i - 1 + lv[p] = i + 1 + } else { + lv[p+1] = i + 1 + uv[p+1] = uv[p] + uv[p] = i - 1 + } + + p = p + 1 # push onto stack + } + } +end + + +# RG_SQSORT -- Sort two real arrays of data in increasing order using a +# secondary key. The data is assumed to have been already sorted on +# the primary key. The input and output index arrays may be the same. + +procedure rg_sqsort (sdata, pdata, a, b, npix) + +real sdata[npix] #I the secondary key +real pdata[npix] #I the primary key +int a[npix] #I the sorted index from the primary key +int b[npix] #O the sorted output index +int npix #I number of pixels + +int i, ndup, first + +begin + # Copy the index array. + call amovi (a, b, npix) + + # Initialize. + ndup = 0 + for (i = 2; i <= npix; i = i + 1) { + if (pdata[b[i]] <= pdata[b[i-1]]) + ndup = ndup + 1 + else if (ndup > 0) { + first = i - 1 - ndup + call rg_qsortr (sdata, b[first], b[first], ndup + 1) + ndup = 0 + } + } +end diff --git a/pkg/images/lib/rgtransform.x b/pkg/images/lib/rgtransform.x new file mode 100644 index 00000000..da9f8210 --- /dev/null +++ b/pkg/images/lib/rgtransform.x @@ -0,0 +1,947 @@ +include +include +include "xyxymatch.h" + +# RG_GETREFTIE -- Get the reference pixel coordinate tie points by reading +# the image cursor or a file. + +int procedure rg_getreftie (fd, xreftie, yreftie, ntie, file_type, interactive) + +int fd #I the input file descriptor +real xreftie[ARB] #O the output x coordinates of the tie points +real yreftie[ARB] #O the output y coordinates of the tie points +int ntie #I the number of tie points +int file_type #I the input file type +bool interactive #I the + +int nref, wcs, key +pointer sp, str +int clgcur(), fscan(), nscan() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Print the prompt string. + if (interactive) { + + # Issue prompt. + if (file_type == RG_REFFILE) { + call printf ( + "\nMark 1-%d reference objects on the display\n") + } else { + call printf ( + "\nMark the same %d input objects on the display\n") + } + call pargi (ntie) + + # Mark the points + nref = 0 + while (clgcur ("icommands", xreftie[nref+1], yreftie[nref+1], + wcs, key, Memc[str], SZ_LINE) != EOF) { + nref = nref + 1 + if (file_type == RG_REFFILE) { + call printf (" Reference coordinate %d %0.3f %0.3f\n") + call pargi (nref) + call pargr (xreftie[nref]) + call pargr (yreftie[nref]) + } else { + call printf (" Input coordinate %d %0.3f %0.3f\n") + call pargi (nref) + call pargr (xreftie[nref]) + call pargr (yreftie[nref]) + } + if (nref >= ntie) + break + } + + } else { + + # Issue prompt. + if (fd == STDIN) { + if (file_type == RG_REFFILE) { + call printf ( + "\nEnter coordinates of 1-%d reference objects\n") + } else { + call printf ( + "Enter coordinates of %d corresponding input objects\n") + } + call pargi (ntie) + } + + nref = 0 + while (fscan (fd) != EOF) { + call gargr (xreftie[nref+1]) + call gargr (yreftie[nref+1]) + if (nscan() < 2) + break + nref = nref + 1 + if (nref >= ntie) + break + call gargr (xreftie[nref+1]) + call gargr (yreftie[nref+1]) + if (nscan() < 4) + break + nref = nref + 1 + if (nref >= ntie) + break + call gargr (xreftie[nref+1]) + call gargr (yreftie[nref+1]) + if (nscan() < 6) + break + nref = nref + 1 + break + } + + } + + call sfree (sp) + + return (nref) +end + + +# RG_GETREFCEL -- Get the reference pixel coordinate tie points by reading +# the image cursor or a file. + +int procedure rg_getrefcel (fd, xreftie, yreftie, ntie, projection, + reflng, reflat, lngunits, latunits, file_type) + +int fd #I the input file descriptor +real xreftie[ARB] #O the output x coordinates of the tie points +real yreftie[ARB] #O the output y coordinates of the tie points +int ntie #I the number of tie points +char projection[ARB] #I the sky projection geometry +double reflng #I the ra / longitude of the reference point +double reflat #I the dec / latitude of the reference point +int lngunits #I the ra / longitude units +int latunits #I the dec / latitude units +int file_type #I the input file type + +int nref +pointer sp, dxref, dyref, str +int fscan(), nscan() + +begin + # Allocate temporary space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (dxref, ntie, TY_DOUBLE) + call salloc (dyref, ntie, TY_DOUBLE) + + # Issue prompt. + if (fd == STDIN) { + if (file_type == RG_REFFILE) { + call printf ( + "\nEnter coordinates of 1-%d reference objects\n") + } else { + call printf ( + "Enter coordinates of %d corresponding input objects\n") + } + call pargi (ntie) + } + + # Read in the tie point. + nref = 0 + while (fscan (fd) != EOF) { + call gargd (Memd[dxref+nref]) + call gargd (Memd[dyref+nref]) + if (nscan() < 2) + break + nref = nref + 1 + if (nref >= ntie) + break + call gargd (Memd[dxref+nref]) + call gargd (Memd[dyref+nref]) + if (nscan() < 4) + break + nref = nref + 1 + if (nref >= ntie) + break + call gargd (Memd[dxref+nref]) + call gargd (Memd[dyref+nref]) + if (nscan() < 6) + break + nref = nref + 1 + break + } + + # Convert to standard coordinates. + if (nref > 0) { + call rg_celtostd (projection, Memd[dxref], Memd[dyref], + Memd[dxref], Memd[dyref], nref, reflng, reflat, lngunits, + latunits) + call amulkd (Memd[dxref], 3600.0d0, Memd[dxref], nref) + call amulkd (Memd[dyref], 3600.0d0, Memd[dyref], nref) + call achtdr (Memd[dxref], xreftie, nref) + call achtdr (Memd[dyref], yreftie, nref) + } + + call sfree (sp) + + return (nref) +end + + +# RG_PLINCOEFF -- Print the computed transformation on the standard output. + +procedure rg_plincoeff (xlabel, ylabel, xref, yref, xlist, ylist, ntie, + coeff, ncoeff) + +char xlabel[ARB] #I the x equation label +char ylabel[ARB] #I the x equation label +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x input coordinates +real ylist[ARB] #I the input y input coordinates +int ntie #I number of tie points +real coeff[ARB] #I the output coefficient array +int ncoeff #I the number of coefficients + +int i +real xmag, ymag, xrot, yrot + +begin + # List the tie points on the standard output. + if (ntie > 0) { + do i = 1, ntie { + call printf ( + " tie point: %3d ref: %9.3f %9.3f input: %9.3f %9.3f\n") + call pargi (i) + call pargr (xref[i]) + call pargr (yref[i]) + call pargr (xlist[i]) + call pargr (ylist[i]) + } + call printf ("\n") + } + + # Print the transformation coefficients to the standard output. + call printf ("Initial linear transformation\n") + call printf (" %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (xlabel) + call pargr (coeff[3]) + call pargr (coeff[1]) + call pargr (coeff[2]) + call printf (" %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (ylabel) + call pargr (coeff[6]) + call pargr (coeff[4]) + call pargr (coeff[5]) + call rg_ctogeo (coeff[1], -coeff[2], -coeff[4], coeff[5], xmag, ymag, + xrot, yrot) + call printf ( + " dx: %0.2f dy: %0.2f xmag: %0.3f ymag: %0.3f xrot: %0.1f yrot: %0.1f\n") + call pargr (coeff[3]) + call pargr (coeff[6]) + call pargr (xmag) + call pargr (ymag) + call pargr (xrot) + call pargr (yrot) + call printf ("\n") +end + + +# RG_PMLINCOEFF -- Print the computed transformation on the standard output. + +procedure rg_pmlincoeff (xlabel, ylabel, coeff, ncoeff) + +char xlabel[ARB] #I the x equation label +char ylabel[ARB] #I the x equation label +real coeff[ARB] #I the output coefficient array +int ncoeff #I the number of coefficients + +real xmag, ymag, xrot, yrot + +begin + # Write the matched transformation coefficients to the standard output. + call printf ("Matched triangles transformation\n") + call printf (" %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (xlabel) + call pargr (coeff[3]) + call pargr (coeff[1]) + call pargr (coeff[2]) + call printf (" %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (ylabel) + call pargr (coeff[6]) + call pargr (coeff[4]) + call pargr (coeff[5]) + call rg_ctogeo (coeff[1], -coeff[2], -coeff[4], coeff[5], xmag, ymag, + xrot, yrot) + call printf ( + " dx: %0.2f dy: %0.2f xmag: %0.3f ymag: %0.3f xrot: %0.1f yrot: %0.1f\n") + call pargr (coeff[3]) + call pargr (coeff[6]) + call pargr (xmag) + call pargr (ymag) + call pargr (xrot) + call pargr (yrot) + call printf ("\n") +end + + +# RG_WLINCOEFF -- Write the computed transformation to the output file. + +procedure rg_wlincoeff (fd, xlabel, ylabel, xref, yref, xlist, ylist, ntie, + coeff, ncoeff) + +int fd #I pointer to the output file +char xlabel[ARB] #I the x equation label +char ylabel[ARB] #I the x equation label +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x input coordinates +real ylist[ARB] #I the input y input coordinates +int ntie #I number of tie points +real coeff[ARB] #I the output coefficient array +int ncoeff #I the number of coefficients + +int i +real xmag, ymag, xrot, yrot + +begin + # List the tie points. + if (ntie > 0) { + do i = 1, ntie { + call fprintf (fd, + "# tie point: %3d ref: %9.3f %9.3f input: %9.3f %9.3f\n") + call pargi (i) + call pargr (xref[i]) + call pargr (yref[i]) + call pargr (xlist[i]) + call pargr (ylist[i]) + } + call fprintf (fd, "#\n") + } + + # Write the transformation coefficients to the output file. + call fprintf (fd, "# Initial linear transformation\n") + call fprintf (fd, + "# %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (xlabel) + call pargr (coeff[3]) + call pargr (coeff[1]) + call pargr (coeff[2]) + call fprintf (fd, + "# %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (ylabel) + call pargr (coeff[6]) + call pargr (coeff[4]) + call pargr (coeff[5]) + call rg_ctogeo (coeff[1], -coeff[2], -coeff[4], coeff[5], xmag, ymag, + xrot, yrot) + call fprintf (fd, + "# dx: %0.2f dy: %0.2f xmag: %0.3f ymag: %0.3f xrot: %0.1f yrot: %0.1f\n") + call pargr (coeff[3]) + call pargr (coeff[6]) + call pargr (xmag) + call pargr (ymag) + call pargr (xrot) + call pargr (yrot) + call fprintf (fd, "#\n") +end + + +# RG_WMLINCOEFF -- Print the computed transformation on the standard output. + +procedure rg_wmlincoeff (ofd, xlabel, ylabel, coeff, ncoeff) + +int ofd #I the output file descriptor +char xlabel[ARB] #I the x equation label +char ylabel[ARB] #I the x equation label +real coeff[ARB] #I the output coefficient array +int ncoeff #I the number of coefficients + +real xmag, ymag, xrot, yrot + +begin + # Write the matched transformation coefficients to the output file. + call fprintf (ofd, "# Matched triangles transformation\n") + call fprintf (ofd, + "# %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (xlabel) + call pargr (coeff[3]) + call pargr (coeff[1]) + call pargr (coeff[2]) + call fprintf (ofd, + "# %4.4s[tie] = %10g + %10g * x[tie] + %10g * y[tie]\n") + call pargstr (ylabel) + call pargr (coeff[6]) + call pargr (coeff[4]) + call pargr (coeff[5]) + call rg_ctogeo (coeff[1], -coeff[2], -coeff[4], coeff[5], xmag, ymag, + xrot, yrot) + call fprintf (ofd, + "# dx: %0.2f dy: %0.2f xmag: %0.3f ymag: %0.3f xrot: %0.1f yrot: %0.1f\n") + call pargr (coeff[3]) + call pargr (coeff[6]) + call pargr (xmag) + call pargr (ymag) + call pargr (xrot) + call pargr (yrot) + call fprintf (ofd, "#\n") +end + + +# RG_LINCOEFF -- Compute the transformation given one to three tie points. + +int procedure rg_lincoeff (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x input coordinates +real ylist[ARB] #I the input y input coordinates +int ntie #I number of tie points +real coeff[ARB] #O the output coefficient array +int ncoeff #I the number of coefficients + +int ier, xier, yier, nfcoeff +pointer sp, wts, fcoeff, sx, sy +real xmin, xmax, ymin, ymax +int rg_onestar(), rg_twostar(), rg_threestar() + +begin + switch (ntie) { + case 0: + ier = ERR + case 1: + ier = rg_onestar (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + case 2: + ier = rg_twostar (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + case 3: + ier = rg_threestar (xref, yref, xlist, ylist, ntie, + coeff, ncoeff) + default: + call smark (sp) + call salloc (fcoeff, 3, TY_REAL) + call salloc (wts, ntie, TY_REAL) + call alimr (xlist, ntie, xmin, xmax) + call alimr (ylist, ntie, ymin, ymax) + call gsinit (sx, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call gsinit (sy, GS_POLYNOMIAL, 2, 2, GS_XNONE, xmin, xmax, + ymin, ymax) + call amovkr (1.0, Memr[wts], ntie) + call gsfit (sx, xlist, ylist, xref, Memr[wts], ntie, WTS_UNIFORM, + xier) + call gsfit (sy, xlist, ylist, yref, Memr[wts], ntie, WTS_UNIFORM, + yier) + if (xier == OK && xier == OK) { + call gscoeff (sx, Memr[fcoeff], nfcoeff) + coeff[3] = Memr[fcoeff] + coeff[1] = Memr[fcoeff+1] + coeff[2] = Memr[fcoeff+2] + call gscoeff (sy, Memr[fcoeff], nfcoeff) + coeff[6] = Memr[fcoeff] + coeff[4] = Memr[fcoeff+1] + coeff[5] = Memr[fcoeff+2] + ier = OK + } else + ier = ERR + call gsfree (sx) + call gsfree (sy) + call sfree (sp) + } + + return (ier) +end + + +# RG_COMPUTE -- Transform the input list coordinates. The transformation +# may be done in place. + +procedure rg_compute (xlist, ylist, xtrans, ytrans, nstars, coeff, ncoeff) + +real xlist[ARB] #I the input x coordinates +real ylist[ARB] #I the input y coordinates +real xtrans[ARB] #O the output x transformed coordinates +real ytrans[ARB] #O the output y transformed coordinates +int nstars #I the number of points +real coeff[ARB] #I the input coefficient array +int ncoeff #I the number of coefficients + +int i +real xval, yval + +begin + do i = 1, nstars { + xval = xlist[i] + yval = ylist[i] + xtrans[i] = coeff[1] * xval + coeff[2] * yval + coeff[3] + ytrans[i] = coeff[4] * xval + coeff[5] * yval + coeff[6] + } +end + + +# RG_INTERSECT -- Compute the intersection of two sorted lists given a +# matching tolerance. + +int procedure rg_intersection (ofd, xref, yref, refindex, rlineno, nrefstars, + xlist, ylist, xtrans, ytrans, listindex, ilineno, nliststars, + tolerance, xformat, yformat) + +int ofd #I the output file descriptor +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +int refindex[ARB] #I the input reference coordinates sort index +int rlineno[ARB] #I the input reference coordinate line numbers +int nrefstars #I the number of reference stars +real xlist[ARB] #I the input x list coordinates +real ylist[ARB] #I the input y list coordinates +real xtrans[ARB] #I the input x transformed list coordinates +real ytrans[ARB] #I the input y transformed list coordinates +int listindex[ARB] #I the input list sort index +int ilineno[ARB] #I the input input line numbers +int nliststars #I the number of input stars +real tolerance #I the matching tolerance +char xformat[ARB] #I the output x coordinate format +char yformat[ARB] #I the output y coordinate format + +int blp, rp, rindex, lp, lindex, rmatch, lmatch, ninter +pointer sp, fmtstr +real dx, dy, tol2, rmax2, r2 + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Construct the fromat string + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %%5d %%5d\n") + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + + # Initialize the intersection routine. + tol2 = tolerance ** 2 + blp = 1 + ninter = 0 + + # Loop over the reference list stars. + for (rp = 1; rp <= nrefstars; rp = rp + 1) { + + # Get the index of the reference star in question. + rindex = refindex[rp] + + # Compute the start of the search range. + for (; blp <= nliststars; blp = blp + 1) { + lindex = listindex[blp] + dy = yref[rindex] - ytrans[lindex] + if (dy < tolerance) + break + } + + # Break if the end of the input list is reached. + if (blp > nliststars) + break + + # If one is outside the tolerance limits skip to next reference + # object. + if (dy < -tolerance) + next + + # Find the closest match to the reference object. + rmax2 = tol2 + rmatch = 0 + lmatch = 0 + for (lp = blp; lp <= nliststars; lp = lp + 1) { + + # Compute the distance between the two points. + lindex = listindex[lp] + dy = yref[rindex] - ytrans[lindex] + if (dy < -tolerance) + break + dx = xref[rindex] - xtrans[lindex] + r2 = dx ** 2 + dy ** 2 + + # A match has been found. + if (r2 <= rmax2) { + rmax2 = r2 + rmatch = rindex + lmatch = lindex + } + } + + # A match was found so write the results to the output file. + if (rmatch > 0 && lmatch > 0) { + ninter = ninter + 1 + call fprintf (ofd, Memc[fmtstr]) + call pargr (xref[rmatch]) + call pargr (yref[rmatch]) + call pargr (xlist[lmatch]) + call pargr (ylist[lmatch]) + call pargi (rlineno[rmatch]) + call pargi (ilineno[lmatch]) + } + } + + call sfree (sp) + + return (ninter) +end + + +# RG_LLINTERSECT -- Compute the intersection of two sorted lists given a +# matching tolerance. + +int procedure rg_llintersect (ofd, lngref, latref, xref, yref, refindex, + rlineno, nrefstars, xlist, ylist, xtrans, ytrans, listindex, ilineno, + nliststars, tolerance, lngformat, latformat, xformat, yformat) + +int ofd #I the output file descriptor +double lngref[ARB] #I the input ra/longitude reference coordinates +double latref[ARB] #I the input dec/latitude reference coordinates +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +int refindex[ARB] #I the input reference coordinates sort index +int rlineno[ARB] #I the input reference coordinate line numbers +int nrefstars #I the number of reference stars +real xlist[ARB] #I the input x list coordinates +real ylist[ARB] #I the input y list coordinates +real xtrans[ARB] #I the input x transformed list coordinates +real ytrans[ARB] #I the input y transformed list coordinates +int listindex[ARB] #I the input list sort index +int ilineno[ARB] #I the input input line numbers +int nliststars #I the number of input stars +real tolerance #I the matching tolerance +char lngformat[ARB] #I the output ra / longitude coordinate format +char latformat[ARB] #I the output dec / latitude coordinate format +char xformat[ARB] #I the output x coordinate format +char yformat[ARB] #I the output y coordinate format + +int blp, rp, rindex, lp, lindex, rmatch, lmatch, ninter +pointer sp, fmtstr +real dx, dy, tol2, rmax2, r2 + +begin + call smark (sp) + call salloc (fmtstr, SZ_LINE, TY_CHAR) + + # Construct the fromat string + call sprintf (Memc[fmtstr], SZ_LINE, "%s %s %s %s %%5d %%5d\n") + if (lngformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (lngformat) + if (latformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (latformat) + if (xformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (xformat) + if (yformat[1] == EOS) + call pargstr ("%13.7g") + else + call pargstr (yformat) + + # Initialize the intersection routine. + tol2 = tolerance ** 2 + blp = 1 + ninter = 0 + + # Loop over the reference list stars. + for (rp = 1; rp <= nrefstars; rp = rp + 1) { + + # Get the index of the reference star in question. + rindex = refindex[rp] + + # Compute the start of the search range. + for (; blp <= nliststars; blp = blp + 1) { + lindex = listindex[blp] + dy = yref[rindex] - ytrans[lindex] + if (dy < tolerance) + break + } + + # Break if the end of the input list is reached. + if (blp > nliststars) + break + + # If one is outside the tolerance limits skip to next reference + # object. + if (dy < -tolerance) + next + + # Find the closest match to the reference object. + rmax2 = tol2 + rmatch = 0 + lmatch = 0 + for (lp = blp; lp <= nliststars; lp = lp + 1) { + + # Compute the distance between the two points. + lindex = listindex[lp] + dy = yref[rindex] - ytrans[lindex] + if (dy < -tolerance) + break + dx = xref[rindex] - xtrans[lindex] + r2 = dx ** 2 + dy ** 2 + + # A match has been found. + if (r2 <= rmax2) { + rmax2 = r2 + rmatch = rindex + lmatch = lindex + } + } + + # A match was found so write the results to the output file. + if (rmatch > 0 && lmatch > 0) { + ninter = ninter + 1 + call fprintf (ofd, Memc[fmtstr]) + call pargd (lngref[rmatch]) + call pargd (latref[rmatch]) + call pargr (xlist[lmatch]) + call pargr (ylist[lmatch]) + call pargi (rlineno[rmatch]) + call pargi (ilineno[lmatch]) + } + } + + call sfree (sp) + + return (ninter) +end + + +# RG_LMKCOEFF -- Given the geometry of a linear transformation compute +# the coefficients required to tranform from the input to the reference +# system. + +procedure rg_lmkcoeff (xin, yin, xmag, ymag, xrot, yrot, xout, yout, + coeff, ncoeff) + +real xin, yin #I the origin of the input coordinates +real xmag, ymag #I the input x and y scale factors +real xrot, yrot #I the iput x and y rotation factors +real xout, yout #I the origin of the reference coordinates +real coeff[ARB] #O the output coefficient array +int ncoeff #I the number of coefficients + +begin + # Compute the x fit coefficients. + coeff[1] = xmag * cos (DEGTORAD(xrot)) + coeff[2] = -ymag * sin (DEGTORAD(yrot)) + coeff[3] = xout - coeff[1] * xin - coeff[2] * yin + + # Compute the y fit coefficients. + coeff[4] = xmag * sin (DEGTORAD(xrot)) + coeff[5] = ymag * cos (DEGTORAD(yrot)) + coeff[6] = yout - coeff[4] * xin - coeff[5] * yin +end + + +# RG_ONESTAR -- Compute the transformation coefficients for a simple +# shift operation. + +int procedure rg_onestar (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x list coordinates +real ylist[ARB] #I the input y list coordinates +int ntie #I the number of tie points +real coeff[ARB] #O the output coefficient array +int ncoeff #I the number of coefficients + +begin + # Compute the x transformation. + coeff[1] = 1.0 + coeff[2] = 0.0 + coeff[3] = xref[1] - xlist[1] + + # Compute the y transformation. + coeff[4] = 0.0 + coeff[5] = 1.0 + coeff[6] = yref[1] - ylist[1] + + return (OK) +end + + +# RG_TWOSTAR -- Compute the transformation coefficients of a simple shift, +# magnification, and rotation. + +int procedure rg_twostar (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x list coordinates +real ylist[ARB] #I the input y list coordinates +int ntie #I the number of tie points +real coeff[ARB] #O the output coefficient array +int ncoeff #I the number of coefficients + +real rot, mag, dxlis, dylis, dxref, dyref, cosrot, sinrot +real rg_posangle() + +begin + # Compute the deltas. + dxlis = xlist[2] - xlist[1] + dylis = ylist[2] - ylist[1] + dxref = xref[2] - xref[1] + dyref = yref[2] - yref[1] + + # Compute the rotation angle. + rot = rg_posangle (dxref, dyref) - rg_posangle (dxlis, dylis) + cosrot = cos (rot) + sinrot = sin (rot) + + # Compute the magnification factor. + mag = dxlis ** 2 + dylis ** 2 + if (mag <= 0.0) + mag = 0.0 + else + mag = sqrt ((dxref ** 2 + dyref ** 2) / mag) + + # Compute the transformation coefficicents. + coeff[1] = mag * cosrot + coeff[2] = - mag * sinrot + coeff[3] = xref[1] - mag * cosrot * xlist[1] + mag * sinrot * ylist[1] + coeff[4] = mag * sinrot + coeff[5] = mag * cosrot + coeff[6] = yref[1] - mag * sinrot * xlist[1] - mag * cosrot * ylist[1] + + return (OK) +end + + +# RG_THREESTAR -- Compute the transformation coefficients using a simple +# shift, magnification in x and y, rotation, and skew. + +int procedure rg_threestar (xref, yref, xlist, ylist, ntie, coeff, ncoeff) + +real xref[ARB] #I the input x reference coordinates +real yref[ARB] #I the input y reference coordinates +real xlist[ARB] #I the input x list coordinates +real ylist[ARB] #I the input y list coordinates +int ntie #I the number of tie points +real coeff[ARB] #O the output coefficient array +int ncoeff #I the number of coefficients + +real dx23, dx13, dx12, dy23, dy13, dy12, det +bool fp_equalr() +int rg_twostar() + +begin + # Compute the deltas. + dx23 = xlist[2] - xlist[3] + dx13 = xlist[1] - xlist[3] + dx12 = xlist[1] - xlist[2] + dy23 = ylist[2] - ylist[3] + dy13 = ylist[1] - ylist[3] + dy12 = ylist[1] - ylist[2] + + # Compute the determinant. + det = xlist[1] * dy23 - xlist[2] * dy13 + xlist[3] * dy12 + if (fp_equalr (det, 0.0)) + return (rg_twostar (xref, yref, xlist, ylist, ntie, + coeff, ncoeff)) + + # Compute the x transformation. + coeff[1] = (xref[1] * dy23 - xref[2] * dy13 + xref[3] * dy12) / det + coeff[2] = (-xref[1] * dx23 + xref[2] * dx13 - xref[3] * dx12) / det + coeff[3] = (xref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + xref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + xref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det + + # Compute the y transformation. + coeff[4] = (yref[1] * dy23 - yref[2] * dy13 + yref[3] * dy12) / det + coeff[5] = (-yref[1] * dx23 + yref[2] * dx13 - yref[3] * dx12) / det + coeff[6] = (yref[1] * (xlist[2] * ylist[3] - xlist[3] * ylist[2]) + + yref[2] * (ylist[1] * xlist[3] - xlist[1] * ylist[3]) + + yref[3] * (xlist[1] * ylist[2] - ylist[1] * xlist[2])) / det + + return (OK) +end + + +# RG_POSANGLE -- Compute the position angle of a 2D vector. The angle is +# measured counter-clockwise from the positive x axis. + +real procedure rg_posangle (x, y) + +real x #I the x vector component +real y #I the y vector component + +real theta +bool fp_equalr() + +begin + if (fp_equalr (y, 0.0)) { # 0-valued y component + if (x > 0.0) + theta = 0.0 + else if (x < 0.0) + theta = PI + else + theta = 0.0 + } else if (fp_equalr (x, 0.0)) { # 0-valued x component + if (y > 0.0) + theta = PI / 2.0 + else if (y < 0.0) + theta = 3.0 * PI / 2.0 + else + theta = 0.0 + } else if (x > 0.0 && y > 0.0) { # 1st quadrant + theta = atan (y / x) + } else if (x > 0.0 && y < 0.0) { # 4th quadrant + theta = 2.0 * PI + atan (y / x) + } else if (x < 0.0 && y > 0.0) { # 2nd quadrant + theta = PI + atan (y / x) + } else if (x < 0.0 && y < 0.0) { # 3rd quadrant + theta = PI + atan (y / x) + } + + return (theta) +end + + +# RG_CTOGEO -- Transform the linear transformation coefficients to useful +# geometric parameters. + +procedure rg_ctogeo (a, b, c, d, xscale, yscale, xrot, yrot) + +real a #I the x coefficient of the x coordinate fit +real b #I the y coefficient of the x coordinate fit +real c #I the x coefficient of the y coordinate fit +real d #I the y coefficient of the y coordinate fit +real xscale #I output x scale +real yscale #I output y scale +real xrot #I rotation of point on x axis +real yrot #I rotation of point on y axis + +bool fp_equalr() + +begin + xscale = sqrt (a * a + c * c) + yscale = sqrt (b * b + d * d) + + # Get the x and y axes rotation factors. + if (fp_equalr (a, 0.0) && fp_equalr (c, 0.0)) + xrot = 0.0 + else + xrot = RADTODEG (atan2 (-c, a)) + if (xrot < 0.0) + xrot = xrot + 360.0 + + if (fp_equalr (b, 0.0) && fp_equalr (d, 0.0)) + yrot = 0.0 + else + yrot = RADTODEG (atan2 (b, d)) + if (yrot < 0.0) + yrot = yrot + 360.0 +end diff --git a/pkg/images/lib/rgwrdstr.x b/pkg/images/lib/rgwrdstr.x new file mode 100644 index 00000000..5c3cee28 --- /dev/null +++ b/pkg/images/lib/rgwrdstr.x @@ -0,0 +1,53 @@ + +# RG_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure rg_wrdstr (index, outstr, maxch, dict) + +int index #I String index +char outstr[ARB] #O Output string as found in dictionary +int maxch #I Maximum length of output string +char dict[ARB] #IDictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear the output string. + outstr[1] = EOS + + # Return if the dictionary is not long enough. + if (dict[1] == EOS) + return (0) + + # Initialize the counters. + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary. + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + outstr[i - start + 1] = EOS + + # Return index for output string. + return (count) +end + diff --git a/pkg/images/lib/rgxymatch.x b/pkg/images/lib/rgxymatch.x new file mode 100644 index 00000000..3b2b45cb --- /dev/null +++ b/pkg/images/lib/rgxymatch.x @@ -0,0 +1,97 @@ +include + +# RG_RXYL -- Compute the grid of logical coordinates. + +procedure rg_rxyl (xl, yl, nx, ny, x1, x2, y1, y2) + +double xl[ARB] #O array of output x coordinates +double yl[ARB] #O array of output y coordinates +int nx #I the size of the grid in x +int ny #I the size of the grid in y +double x1 #I the lower limit of the grid in x +double x2 #I the upper limit of the grid in x +double y1 #I the lower limit of the grid in y +double y2 #I the upper limit of the grid in y + +double xstep, ystep, x, y +int i, j, npts + +begin + if (nx == 1) + xstep = 0.0d0 + else + xstep = (x2 - x1) / (nx - 1) + if (ny == 1) + ystep = 0.0d0 + else + ystep = (y2 - y1) / (ny - 1) + npts = 0 + + y = y1 + do j = 1, ny { + x = x1 + do i = 1, nx { + npts = npts + 1 + xl[npts] = x + yl[npts] = y + x = x + xstep + } + y = y + ystep + } +end + + +# RG_XYTOXY -- Compute the world coordinate list give the wcs descriptor +# and the logical coordinates. + +pointer procedure rg_xytoxy (mw, xl, yl, xw, yw, npts, inwcs, outwcs, ax1, ax2) + +pointer mw #I the wcs descriptor +double xl[ARB] #I the input logical x coordinate +double yl[ARB] #I the input logical y coordinate +double xw[ARB] #O the output world x coordinate +double yw[ARB] #O the output world y coordinate +int npts #I the number of coordinates. +char inwcs[ARB] #I the input wcs +char outwcs[ARB] #I the output wcs +int ax1 #I the logical x axis +int ax2 #I the logical y axis + +int i, axbits +pointer ct +double mw_c1trand() +int mw_stati() +pointer mw_sctran() +errchk mw_sctran() + +begin + # Compile the transformation. + if (mw == NULL) { + ct = NULL + } else if (mw_stati (mw, MW_NDIM) >= 2) { + axbits = 2 ** (ax1 - 1) + 2 ** (ax2 - 1) + iferr (ct = mw_sctran (mw, inwcs, outwcs, axbits)) + ct = NULL + } else { + axbits = 2 ** (ax1 - 1) + iferr (ct = mw_sctran (mw, inwcs, outwcs, axbits)) + ct = NULL + } + + # Compute the world coordinates. + if (ct == NULL) { + call amovd (xl, xw, npts) + call amovd (yl, yw, npts) + } else if (mw_stati (mw, MW_NDIM) == 2) { + do i = 1, npts + call mw_c2trand (ct, xl[i], yl[i], xw[i], yw[i]) + } else { + do i = 1, npts { + xw[i] = mw_c1trand (ct, xl[i]) + yw[i] = yl[i] + } + } + + return (ct) +end + diff --git a/pkg/images/lib/xymatch.x b/pkg/images/lib/xymatch.x new file mode 100644 index 00000000..96907578 --- /dev/null +++ b/pkg/images/lib/xymatch.x @@ -0,0 +1,175 @@ +include "xyxymatch.h" + +# RG_RDXYI -- Read in the x and y coordinates from a file and set the +# line number index. + +int procedure rg_rdxyi (fd, x, y, lineno, xcolumn, ycolumn) + +int fd #I the input file descriptor +pointer x #U pointer to the x coordinates +pointer y #U pointer to the y coordinates +pointer lineno #U pointer to the line numbers +int xcolumn #I column containing the x coordinate +int ycolumn #I column containing the y coordinate + +int i, ip, bufsize, npts, lnpts, maxcols +pointer sp, str +real xval, yval +int fscan(), nscan(), ctor() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + bufsize = DEF_BUFSIZE + call malloc (x, bufsize, TY_REAL) + call malloc (y, bufsize, TY_REAL) + call malloc (lineno, bufsize, TY_INT) + maxcols = max (xcolumn, ycolumn) + + npts = 0 + lnpts = 0 + while (fscan(fd) != EOF) { + + lnpts = lnpts + 1 + xval = INDEFR + yval = INDEFR + do i = 1, maxcols { + call gargwrd (Memc[str], SZ_LINE) + if (i != nscan()) + break + ip = 1 + if (i == xcolumn) { + if (ctor (Memc[str], ip, xval) <= 0) + xval = INDEFR + } else if (i == ycolumn) { + if (ctor (Memc[str], ip, yval) <= 0) + yval = INDEFR + } + } + if (IS_INDEFR(xval) || IS_INDEFR(yval)) + next + + Memr[x+npts] = xval + Memr[y+npts] = yval + Memi[lineno+npts] = lnpts + npts = npts + 1 + if (npts >= bufsize) { + bufsize = bufsize + DEF_BUFSIZE + call realloc (x, bufsize, TY_REAL) + call realloc (y, bufsize, TY_REAL) + call realloc (lineno, bufsize, TY_INT) + } + } + + call sfree (sp) + + return (npts) +end + + +# RG_SORT -- If the coordinates are not already sorted, sort the coordinates +# first in y then in x. Remove points which are close together than a given +# tolerance, if the coincident point remove flag is on. + +int procedure rg_sort (xcoord, ycoord, rsindex, npts, tolerance, sort, coincid) + +real xcoord[ARB] #I pointer to the x coordinates +real ycoord[ARB] #I pointer to the y coordinates +int rsindex[ARB] #I pointer to sort index +int npts #I the number of objects +real tolerance #I coincidence tolerance in pixels +int sort #I sort the pixels ? +int coincid #I remove coincident points + +int i, ndif +int rg_xycoincide() + +begin + # Initialize the sort index. + do i = 1, npts + rsindex[i] = i + + # Sort the pixels in y and then x if the arrays are unsorted. + if (sort == YES) { + call rg_qsortr (ycoord, rsindex, rsindex, npts) + call rg_sqsort (xcoord, ycoord, rsindex, rsindex, npts) + } + + # Remove objects that are closer together than tolerance. + if (coincid == NO) + ndif = npts + else + ndif = rg_xycoincide (xcoord, ycoord, rsindex, rsindex, npts, + tolerance) + + return (ndif) +end + + +# RG_XYCOINCIDE -- Remove points from a list which are closer together than +# a specified tolerance. The arrays are assumed to be sorted first in y then +# in x. + +int procedure rg_xycoincide (xcoord, ycoord, a, b, npts, tolerance) + +real xcoord[ARB] #I the input x coordinate values +real ycoord[ARB] #I the input y coordinate values +int a[ARB] #I the input sort index +int b[ARB] #O the output sort index +int npts #I the number of points +real tolerance #I the coincidence tolerace + +int iprev, i, nunique +real tol2, r2 + +begin + tol2 = tolerance ** 2 + nunique = npts + + iprev = 1 + repeat { + + do i = iprev + 1, npts { + + # Jump to the next object if this one has been deleted + # since all comparisons are then invalid. + if (a[iprev] == 0) + break + + # Skip to the next object if this one has been deleted. + if (a[i] == 0) + next + + # Check the tolerance limit in y and step to the next object + # if the bounds are exceeded. + r2 = (ycoord[a[i]] - ycoord[a[iprev]]) ** 2 + if (r2 > tol2) + break + + # Check the tolerance limit. + r2 = r2 + (xcoord[a[i]] - xcoord[a[iprev]]) ** 2 + if (r2 <= tol2) { + a[i] = 0 + nunique = nunique - 1 + } + } + + iprev = iprev + 1 + + } until (iprev >= npts) + + # Reorder the index array. + if (nunique < npts) { + iprev = 0 + do i = 1, npts { + if (a[i] != 0) { + iprev = iprev + 1 + b[iprev] = a[i] + } + } + } + + return (nunique) +end + diff --git a/pkg/images/lib/xyxymatch.h b/pkg/images/lib/xyxymatch.h new file mode 100644 index 00000000..50e44e74 --- /dev/null +++ b/pkg/images/lib/xyxymatch.h @@ -0,0 +1,35 @@ +# The definitions file for the LINXYMATCH task + +# Define the matching algorithms + +define RG_MATCHSTR "|tolerance|triangles|" +define RG_TOLERANCE 1 # Match by tolerance only +define RG_TRIANGLES 2 # Match by triangles + +# Define the reference and input files types + +define RG_REFFILE 1 # The input reference coordinate file +define RG_INFILE 2 # The input coordinate file + +# Define some useful constants + +define MAX_NTIE 3 # Maximum number of tie points +define MAX_NCOEFF 6 # Maximum number of coefficients +define DEF_BUFSIZE 1000 # The default buffer size +define SZ_TRIINDEX 6 # Number of triangle indices to save. +define SZ_TRIPAR 5 # Number of triangle parameters + +# Define the structure of the internal arrays used by the trangles algorithm + +define RG_INDEX 1 # Sort index +define RG_X1 2 # Vertex 1 +define RG_X2 3 # Vertex 2 +define RG_X3 4 # Vertex 3 +define RG_CC 5 # Counterclockwise ? +define RG_MATCH 6 # Match index + +define RG_LOGP 1 # Log of the perimeter +define RG_RATIO 2 # Ratio of longest to shortest side +define RG_COS1 3 # Cos of angle at vertex 1 +define RG_TOLR 4 # Tolerance in the ratio +define RG_TOLC 5 # Tolerance in the cosine diff --git a/pkg/images/lib/zzdebug.x b/pkg/images/lib/zzdebug.x new file mode 100644 index 00000000..d80be43f --- /dev/null +++ b/pkg/images/lib/zzdebug.x @@ -0,0 +1,430 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# Simples IMIO test routines. + +task mkimage = t_mkimage, + mktest = t_mktest, + cube = t_cube, + maxmin = t_maxmin, + gsubras = t_gsubras, + dump = t_dump + + +include +include +include +include + + +define NTYPES 7 + +# MKIMAGE -- Make a new two dimensional image of a specified size +# and datatype. The image pixels are all set to zero. + +procedure t_mkimage() + +int dtype +real pixval +int ncols, nlines +char imname[SZ_FNAME] +char title[SZ_LINE] +short ty_code[NTYPES] + +real clgetr() +char clgetc(), ch +int clgeti(), stridx() + +string types "usilrdx" # Supported pixfile datatypes +data ty_code /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, + TY_DOUBLE, TY_COMPLEX/ +begin + call clgstr ("image", imname, SZ_FNAME) + ncols = clgeti ("ncols") + nlines = clgeti ("nlines") + ch = clgetc ("datatype") + dtype = ty_code[stridx(ch,types)] + pixval = clgetr ("pixval") + call clgstr ("title", title, SZ_LINE) + + call immake2 (imname, ncols, nlines, dtype, pixval, title) +end + + +# IMMAKE2 -- Make a two dimensional image of datatype [usilr] with all pixels +# set to the given value. + +procedure immake2 (imname, ncols, nlines, dtype, pixval, title) + +char imname[ARB] # name of new image +int ncols, nlines # image size +int dtype # datatype +real pixval # constant pixel value +char title[ARB] # image title + +int i +pointer im, buf +pointer immap(), impl2r() + +begin + im = immap (imname, NEW_IMAGE, 0) + + IM_PIXTYPE(im) = dtype + IM_LEN(im,1) = ncols + IM_LEN(im,2) = nlines + call strcpy (title, IM_TITLE(im), SZ_IMTITLE) + + # Write out the lines. + + do i = 1, nlines { + buf = impl2r (im, i) + call amovkr (pixval, Memr[buf], ncols) + } + + call imunmap (im) +end + + +# MKTEST -- Make a test image. + +procedure t_mktest() + +char imname[SZ_FNAME] +int ndim, dim[IM_MAXDIM] +int i, j, k, scalar +long offset +int clgeti(), nscan(), clscan(), stridx() +pointer buf, im, immap(), impl3l() + +int dtype +string types "usilrdx" # Supported pixfile datatypes +char ty_code[7], clgetc() +data ty_code /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, + TY_DOUBLE, TY_COMPLEX, EOS/ + +begin + call clgstr ("image_name", imname, SZ_FNAME) + dtype = ty_code[stridx (clgetc ("datatype"), types)] + ndim = clgeti ("ndim") + + call amovki (1, dim, 3) + if (clscan ("axis_lengths") != EOF) { + do i = 1, ndim + call gargi (dim[i]) + if (nscan() < ndim) + call error (1, "Insufficient dimensions") + } + + im = immap (imname, NEW_IMAGE, 0) + + IM_PIXTYPE(im) = dtype + do i = 1, ndim + IM_LEN(im,i) = dim[i] + + do k = 1, dim[3] + do j = 1, dim[2] { + buf = impl3l (im, j, k) + + # Pixel value eq pixel coords. + offset = 1 + if (ndim > 1) { + if (dim[1] < 100) + scalar = 100 + else + scalar = 1000 + offset = offset + j * scalar + } + + if (ndim > 2) + offset = offset + k * (scalar ** 2) + + # Avoid integer overflow if large type short image. + if (IM_PIXTYPE(im) == TY_SHORT) + offset = min (MAX_SHORT, offset - dim[1]) + + # Initialize line of pixels. + do i = 0, dim[1]-1 + Meml[buf+i] = offset + i + } + + call imunmap (im) +end + + +# CUBE -- Get a subraster from an image, and print out the pixel values +# on the standard output. + +define MAXDIM 3 + +procedure t_cube() + +char imname[SZ_FNAME], fmt +int i, nx, ny, nz, ndim +int vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer im, ras, imgs3r(), immap() +int clscan(), nscan() +char clgetc() + +begin + call clgstr ("image_name", imname, SZ_FNAME) + fmt = clgetc ("numeric_format") + + im = immap (imname, READ_ONLY, 0) + + # Get the coordinates of the subraster to be extracted. Determine + # dimensionality of subraster. + + if (clscan ("subraster_coordinates") != EOF) { + for (ndim=1; ndim <= MAXDIM; ndim=ndim+1) { + switch (fmt) { + case FMT_DECIMAL: + call gargi (vs[ndim]) + call gargi (ve[ndim]) + case FMT_OCTAL: + call gargrad (vs[ndim], 8) + call gargrad (ve[ndim], 8) + case FMT_HEX: + call gargrad (vs[ndim], 16) + call gargrad (ve[ndim], 16) + } + + if (nscan() < ndim * 2) { + ndim = nscan() / 2 + break + } + } + } + + if (ndim == 0) + return + + for (i=ndim+1; i <= MAXDIM; i=i+1) { + vs[i] = 1 + ve[i] = 1 + } + + # Extract subraster from image. Print table on the standard + # output. + + ras = imgs3r (im, vs[1], ve[1], vs[2], ve[2], vs[3], ve[3]) + call imbln3 (im, nx, ny, nz) + + call print_cube (STDOUT, Memr[ras], nx, ny, nz, vs, ve, fmt) + call imunmap (im) +end + + +# PRINT_CUBE -- Print a cube of pixels of type REAL on a file. + +procedure print_cube (fd, cube, nx, ny, nz, vs, ve, fmt) + +char fmt +int fd, nx, ny, nz +real cube[nx,ny,nz] +int vs[MAXDIM], ve[MAXDIM], vinc[MAXDIM] +int i, j, k +errchk fprintf, pargi, pargr + +begin + do i = 1, MAXDIM # loop increments + if (vs[i] <= ve[i]) + vinc[i] = 1 + else + vinc[i] = -1 + + # Print table of pixel values on the standard output. Label bands, + # lines, and columns. + + do k = 1, nz { + call fprintf (fd, "Band %0.0*:\n") + call pargc (fmt) + call pargi (vs[MAXDIM] + (k-1) * vinc[MAXDIM]) + + call fprintf (fd, "%9w") + do i = 1, nx { # label columns + call fprintf (fd, "%9* ") + call pargc (fmt) + call pargi (vs[1] + (i-1) * vinc[1]) + } + call fprintf (fd, "\n") + + do j = 1, ny { + call fprintf (fd, "%5* ") + call pargc (fmt) + call pargi (vs[2] + (j-1) * vinc[2]) + do i = 1, nx { # print pixels + call fprintf (fd, "%12*") + call pargc (fmt) + call pargr (cube[i,j,k]) + } + call fprintf (fd, "\n") + } + call fprintf (fd, "\n") + } +end + + +# MAXMIN -- Compute the minimum and maximum pixel values of an image. +# Works for images of any dimensionality, size, or datatype. + +procedure t_maxmin() + +char imname[SZ_FNAME] +real minval, maxval +long v[IM_MAXDIM], clktime() +pointer im, buf, immap(), imgnlr() + +begin + call clgstr ("imname", imname, SZ_FNAME) + call amovkl (long(1), v, IM_MAXDIM) # start vector + + im = immap (imname, READ_WRITE, 0) + + # Only calculate minimum, maximum pixel values if the current + # values are unknown, or if the image was modified since the + # old values were computed. + + if (IM_LIMTIME(im) < IM_MTIME(im)) { + IM_MIN(im) = MAX_REAL + IM_MAX(im) = -MAX_REAL + + while (imgnlr (im, buf, v) != EOF) { + call alimr (Memr[buf], IM_LEN(im,1), minval, maxval) + IM_MIN(im) = min (IM_MIN(im), minval) + IM_MAX(im) = max (IM_MAX(im), maxval) + } + + IM_LIMTIME(im) = clktime (long(0)) + } + + call clputr ("minval", IM_MIN(im)) + call clputr ("maxval", IM_MAX(im)) + + call imunmap (im) +end + + +define MAXDIM 3 + +# GSUBRAS -- Get a type short subraster from an image, and print out the +# minimum and maximum pixel values on the standard output. + +procedure t_gsubras() + +char imname[SZ_FNAME], fmt +int i, nx, ny, nz, ndim +int vs[IM_MAXDIM], ve[IM_MAXDIM] +short minval, maxval +pointer im, ras +pointer imgs1s(), imgs2s(), imgs3s(), immap() +int clscan(), nscan() +char clgetc() + +begin + call clgstr ("image_name", imname, SZ_FNAME) + fmt = clgetc ("numeric_format") + + im = immap (imname, READ_ONLY, 0) + + # Get the coordinates of the subraster to be extracted. Determine + # dimensionality of subraster. + + if (clscan ("subraster_coordinates") != EOF) { + for (ndim=1; ndim <= MAXDIM; ndim=ndim+1) { + switch (fmt) { + case FMT_DECIMAL: + call gargi (vs[ndim]) + call gargi (ve[ndim]) + case FMT_OCTAL: + call gargrad (vs[ndim], 8) + call gargrad (ve[ndim], 8) + case FMT_HEX: + call gargrad (vs[ndim], 16) + call gargrad (ve[ndim], 16) + } + + if (nscan() < ndim * 2) { + ndim = nscan() / 2 + break + } + } + ndim = min (MAXDIM, ndim) + } + + if (ndim == 0) + return + + for (i=ndim+1; i <= MAXDIM; i=i+1) { + vs[i] = 1 + ve[i] = 1 + } + + # Extract subraster from image. Print table on the standard + # output. + + switch (ndim) { + case 1: + ras = imgs1s (im, vs[1], ve[1]) + call imbln1 (im, nx) + ny = 1 + nz = 1 + case 2: + ras = imgs2s (im, vs[1], ve[1], vs[2], ve[2]) + call imbln2 (im, nx, ny) + nz = 1 + case 3: + ras = imgs3s (im, vs[1], ve[1], vs[2], ve[2], vs[3], ve[3]) + call imbln3 (im, nx, ny, nz) + } + + minval = MAX_SHORT + maxval = -MAX_SHORT + call alims (Mems[ras], nx * ny * nz, minval, maxval) + + call printf ("min = %0.0*, max = %0.0*\n") + call pargc (fmt) + call pargs (minval) + call pargc (fmt) + call pargs (maxval) + + call imunmap (im) +end + + +# DUMP -- Dump the user area of an image header for diagnostic purposes. +# Blanks are rendered into underscores to make them visible. This is a +# throwaway task. + +procedure t_dump() + +char image[SZ_FNAME] +int i +pointer ip, im +pointer immap() + +begin + call clgstr ("image", image, SZ_FNAME) + im = immap (image, READ_ONLY, 0) + + # Print ruler. + do i = 1, 80 + if (mod(i,10) == 0) + call putci (STDOUT, TO_DIGIT(i/10)) + else + call putci (STDOUT, ' ') + call putci (STDOUT, '\n') + + do i = 1, 80 + call putci (STDOUT, TO_DIGIT(mod(i,10))) + call putci (STDOUT, '\n') + + # Map blanks into underscores. + for (ip = IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ' ') + Memc[ip] = '_' + + # Dump user area. + call putline (STDOUT, Memc[IM_USERAREA(im)]) + call imunmap (im) +end + diff --git a/pkg/images/mkpkg b/pkg/images/mkpkg new file mode 100644 index 00000000..d6c6df18 --- /dev/null +++ b/pkg/images/mkpkg @@ -0,0 +1,33 @@ +# Make the IMAGES package + +$call relink +$exit + +update: + @tv + @immatch/src/imcombine/src/mkpkg + $call relink + $call install + ; + +relink: + $set LIBS1 = "-limc -lxtools -lcurfit -lsurfit -lgsurfit -liminterp" + $set LIBS2 = "-lnlfit -lslalib -lncar -lgks" + $update libpkg.a + $omake x_images.x + $link x_images.o libpkg.a $(LIBS1) $(LIBS2) -o xx_images.e + ; + +install: + $move xx_images.e bin$x_images.e + ; + +libpkg.a: + @imcoords + @imfilter + @imfit + @imgeom + @immatch + @imutil + @lib + ; diff --git a/pkg/images/notes b/pkg/images/notes new file mode 100644 index 00000000..03a97c7c --- /dev/null +++ b/pkg/images/notes @@ -0,0 +1,341 @@ + +Doug, + + I have finished the initial IMAGES package reorganization. The following +notes should give a pretty good sumary of what I have done to date. + + Lindsey + +IMAGES PACKAGE REORGANIZATION + +I. GENERAL COMMENTS + +The first version of the revised IMAGES package is now available for review. +At present the revised package is called IMAGESX annd can be loaded and +executed on tucana by creating the following environment and package +definitions. + + set imagesx = /d1/davis/imagesx/ + task imagesx.pkg = imagesx$imagesx.cl + +IMAGESX is not an external package so the help database has not been built. +However all the .hd, .men, and .hlp files should have proper entries and +be in their proper places. + +The old TV subpackage is not yet installed in IMAGESX as I did not alter +its organization or appearance to the user. + +II. PACKAGE STRUCTURE AND SUBPACKAGE NAMES + +IMAGESX contains 83 (29 are new to the images package) tasks divided into +the following 8 logical subpackages. + +IMALGEBRA - Image expression evaluation package # e.g. imarith, imexpr + IMCOORDS - Image coordinates package # e.g. ccmap, ccsetwcs + IMFIT - Image fitting package # e.g. fit1d, imsurfit + IMFILTER - Image filtering package # e.g. boxcar, gauss +IMGEOTRAN - Image geometric transformation package # e.g. rotate, magnify + IMMATCH - Image matching and combining package # e.g. xregister, imcombine + IMTV - Image display utilities package # e.g. display, imexamine + IMUTIL - Image utilities package # e.g. hedit, imcopy + +The subpackage names have been prefixed with IM for consistency and to +minimize possible name conflicts with tasks in other packages (e.g. IMMATCH +and MATCH, IMGEOTRAN and GEOTRAN, IMCOORDS and COORDS) and for consistency +with other package names (IMUTIL and ASTUTIL). They were also chosen to avoid +conflict with the names of existing tasks. These names should be reviewed +carefully as we want to live with them for awhile. + +Using the IM prefix implies that the existing images subpackage TV should be +renamed to IMTV in the new scheme. + +The only subpackage name conflict I am aware of is that of IMMATCH with the +CTIO.IMMATCH task which is a 1D version of the current XREGISTER task. + + +III. PACKAGE DIRECTORY STRUCTURE + +The main IMAGESX directory stucture currently looks like the following + +drwxr-xr-x 4 davis 512 Jan 22 10:39 imalgebra +drwxr-xr-x 4 davis 512 Jan 20 15:18 imcoords +drwxr-xr-x 4 davis 512 Jan 13 14:30 imfilter +drwxr-xr-x 4 davis 512 Jan 13 09:36 imfit +drwxr-xr-x 4 davis 512 Jan 23 13:53 imgeotran +drwxr-xr-x 4 davis 1024 Jan 23 14:06 immatch +drwxr-xr-x 2 davis 512 Jan 23 14:29 imtv +drwxr-xr-x 4 davis 1024 Jan 23 14:06 imutil +drwxr-xr-x 2 davis 1024 Jan 20 12:22 lib + +The subdirectory names mimic the names of the subpackages with the exception +of LIB which contains source that is either used by tasks in more than one +subpackage or is of sufficiently general interest that it might make an XTOOLS +package or routine at some point. + +IV. PACKAGE EXECUTABLE + +All the tasks except the IMTV tasks (which are not hooked up yet) are +currently in the same executable as is the case for the current IMAGES +package. + + +V. REORGANIZATION RELATED CHANGES TO EXISTING IMAGES PACKAGE TASKS + +The undocumented tasks in the IMDEBUG package have been removed. These +are CUBE, DUMP, GSUBRAS, MAXMIN, MKIMAGE, and MKTEST. All of these tasks except +DUMP have been superseded by tasks in the IMAGES or ARTDATA packages. +DUMP is occasionally useful for diagnosing problems with pathological image +headers and could be documented and moved to PROTO. + +The script task REGISTER (a simple script task on top of GEOTRAN) has +been renamed GREGISTER to indicate is close ties to GEOMAP/GEOTRAN and +to make it look less generic when listed with other REGISTRATION tasks like +XREGISTER (x-correlation registration) and SREGISTER (celestial coordinate +wcs registration). + + +VI. SUBPACKAGES + +The tasks in each subpackage are described below. New tasks are starred and +their origins described in the notes section. + +In some cases a task appears in the listing for more than one subpackage. For +example WCSCOPY appears in IMMATCH but is also included in IMCOORDS because +it is part of the image matching process but can also be a useful utility. +In all cases where this occurs there is only one version of the parameter file. + +VI.I IMALGEBRA + +This subpackage contains various image arithmetic, function, and expression +evaluation routines. This package should eventually include the image +calculator is also a good place to put various other simple image operator +routines as they are written. + +images.imalgebra: + + imarith - Simple image arithmetic + imdivide - Image division with zero checking and rescaling + imexpr - Evaluate a general image expression +*imfunction - Apply a single argument function to a list of images + imsum - Compute the sum, average, or median of a set of images + +Notes: + +[1] IMFUNCTION is the PROTO package task of the same name. I have included it +here because provides a very simple interface for doing things like computing +the square or square root of an image amd hence complements the IMEXPR task +as IMARITH does. +[2] I chose the subpackage name IMALGEBRA instead of IMCALC to avoid +conflicts with the existing IMCALC tasks (in XRAY and STSDAS) and to leave +the name open for the eventual definitive version of the IMCALC task. + +VI.II IMCOORDS + +This subpackage contains tasks for setting, editing, and transforming image +coordinate systems, and for transforming coordinate lists from one +coordinate system to another using the image coordinate system. All these +tasks are new and either derive from the IMMATCH or PROTO packages. I thought +IMCOORDS was a reasonable name for the subpackage but IMWCS is another +possibility. + +images.imcoords: + +* ccmap - Compute image plate solutions using matched coordinate lists +* ccsetwcs - Create an image celestial wcs from the ccmap plate solution +* cctran - Transform coordinate lists using the ccmap plate solution +* ccxymatch - Match celestial and pixel coordinate lists +* imcctran - Transform image header from one celestial wcs to another +* skyctran - Transform coordinates from one celestial wcs to another +* wcscopy - Replace the wcs of one image with that of another +* wcsctran - Transform coordinates from one iraf image wcs to another +* wcsedit - Edit an image wcs parameter +* wcsreset - Reset the specified image wcs + +Notes: + +[1]. WCSRESET and WCSEDIT are the PROTO package tasks of the same name. They +are very general tasks and work on images of any size and any supported wcs +type. WCSRESET in particular is very useful for removing a world or physical +wcs. +[2]. The remaining tasks were all part of the current IMMATCH package. +[3]. WCSCOPY also appears in immatch package + +VI.III IMFILTER + +This subpackage contains the image filtering tasks. I expect this package +could grow in the future. All of the tasks are in the current IMAGES +package although some like the ring median filters will be new with 2.11. + +images.imfilter: + + boxcar - Boxcar smooth a list of 1 or 2-D images + convolve - Convolve a list of 1 or 2-D images with a rectangular filter + fmedian - Quantize and box median filter a list of 1D or 2D images + fmode - Quantize and box modal filter a list of 1D or 2D images + frmedian - Quantize and ring median filter a list of 1D or 2D images + frmode - Quantize and ring modal filter a list of 1D or 2D images + gauss - Convolve a list of 1 or 2-D images with an elliptical Gaussian + gradient - Convolve a list of 1 or 2-D images with a gradient operator + laplace - Laplacian filter a list of 1 or 2-D images + median - Median box filter a list of 1D or 2D images + mode - Modal box filter a list of 1D or 2D images + rmedian - Ring median filter a list of 1D or 2D images + rmode - Ring modal filter a list of 1D or 2D images + +VI.IV IMFIT + +This subpackage contains the current line and surface fitting tasks. This is +a small package but one which could grow substantially in the future. Examples +of new tasks are a more sophisticated background fitting and surface fitting +tasks, etc. + +images.imfit: + + fit1d - Fit a function to image lines or columns + imsurfit - Fit a surface to a 2-D image + lineclean - Replace deviant pixels in image lines + + +VI.V IMGEOTRAN + +This subpackage contains a set of geometric tranformation operatores which +move pixel and may alter their values via image interpolation. All these +tasks update the wcs information as well. + +imgeotran: + + blkavg - Block average or sum a list of N-D images + blkrep - Block replicate a list of N-D images + geotran - Geometrically transform a list of 1-D or 2-D images + imlintran - Linearly transform a list of 2-D images + imshift - Shift a list of 1-D or 2-D images + imtranspose - Transpose a list of 2-D images +* im3dtran - Transpose a list of 3-D images + magnify - Magnify a list of 1-D or 2-D images + rotate - Rotate and shift a list of 2-D images + shiftlines - Shift the lines of a list of N-D images + +Notes: + +[1]. GEOTRAN also appears in the IMMATCH package. +[2]. IM3DTRAN comes from Steve Rook's VOL package. I added mwcs support. + + +VI.VI IMMATCH + +This subpackage contains tasks for registering or combining images spatially +and for match their psfs and intensity scales. + + +images.immatch: + + geomap - Compute geometric transforms using matched coordinate lists + geotran - Transform 1-D or 2-D images using the [geo|sky|wcs]map transforms +* geoxytran - Transform coordinate lists using the geomap transforms + gregister - Register 1-D or 2-D images using the geomap transforms +* imalign - Align and register 2-D images using a reference x-y list +*imcentroid - Compute and print relative shifts for a list of 2-D images + imcombine - Combine images pixel-by-pixel using various algorithms +* linmatch - Match the linear intensity scales of 1-D or 2-D images +* psfmatch - Match the point-spread functions of 1-D or 2-D images +* skymap - Compute geometric transforms using the image celestial wcs +*skyxymatch - Generate matched x-y lists using the image celestial wcs +* sregister - Register 1-D or 2-D images using the image celestial wcs +* wcscopy - Copy the wcs from one image to another +* wcsmap - Compute geometric transforms using the image wcs +*wcsxymatch - Generate matched x-y lists using the image wcs +* wregister - Register 1-D or 2-D images using the image wcs +* xregister - Register 1-D or 2-D images using x-correlation techniques +* xyxymatch - Match pixel coordinate lists + +Notes: + +[1]. Most of the new tasks come from the IMMATCH package. IMCENTROID and +IMALIGN are the PROTO package image registration tasks of the same name +which I have modified slightly and included in the IMMATCH package as +they offer a useful alternative to XREGISTER. +[2]. The registration tasks (GREGISTER, SREGISTER, and WREGISTER) are +script tasks which call the GEOTRAN task to compute the output image. +They set up the transformation in different ways depending on whether +a matched pixel list, a celestial coordinate system image wcs, or a general +image wcs is to be used. SREGISTER in particular is capable of registering +images which have coordinate systems at different epochs (e.g. 1950 and 2000) +or in different systems (e.g. equatorial and galactic). +[3]. WCSCOPY also appears in the IMCOORDS package. + + +VI.VII IMTV + +This subpackage contains tasks which load and/or interact with the image +display. The package is unchanged except for being called IMTV in the new +scheme. + +images.imtv + + display - Load an image or image section into the display + iis - IIS image display control package + imedit - Examine and edit pixels in images +imexamine - Examine images using image display, graphics, and text + tvmark - Mark objects on the image display + wcslab - Overlay a displayed image with a world coordinat + +VI.VIII IMUTIL + +This subpackage contains the basic images utilities package. + +images.imutil + + chpixtype - Change the pixel type of a list of images + hedit - Header editor + hselect - Select a subset of images satisfying a boolean expression + imcopy - Copy an image + imdelete - Delete a list of images + imgets - Return the value of an image header parameter as a string + imheader - Print an image header + imhistogram - Compute and plot or print an image histogram +* imjoin - Join images along a given dimension + imrename - Rename one or more images +* imreplace - Replace a range of pixel values with a constant + imslice - Slice images into images of lower dimension + imstack - Stack images into a single image of higher dimension +* imtile - Tile same sized 2D images into a 2D mosaic + imstatistics - Compute and print statistics for a list of images + listpixels - Convert an image section into a list of pixels + minmax - Compute the minimum and maximum pixel values in an image + sections - Expand an image template on the standard output + + +Notes: + +[1]. IMJOIN comes from Steve Rooke's VOL package. It joins images of the +same dimension efficiently and complements the IMSTACK task. The wcs of +the resulting image is the wcs of the first image. +[2]. IMREPLACE is the proto package task of the same name. It is a simple +general purpose task that is very useful. +[3]. IMTILE is the old IRMOSAIC task with the database code removed making +it a simple useful 2D image mosaicing task. Often used for combining +before and after pictures of the same field or a time sequence of small images. + + +VII. TASK NAME CONFLICTS WITH EXTERNAL PACKAGES + +The only task name conflict that I am aware concerns the SKYMAP task. There +is a SKYMAP task in STSDAS.GRAPHICS.STPLOT which basically creates a sky +chart for the GSC. Since I would really like to maintain the use +of MAP for my transformation computing tasks (e.g. GEOMAP), I wonder +whether STSDAS would mind renaming this task to SKYCHART... I ran into the name +conflict when I had IMMATCH and GASP loaded at the same time, as GASP uses +the STSDAS version of SKYMAP in some scripts. + + +VIII. WORK STILL TO BE DONE + +I still need to review and if possible implement some changes to the +CCMAP and GEOTRAN tasks requested by Frank. These are mosaic support +related changes. (COMPLETED 8/2/97) + +When and if the new wcs function drivers are installed I will need +to release the contraints I currently have on the CCXYMATC, CCMAP, CCSETWCS, +IMCTRAN, CCTRAN, etc tasks ability to handle various sky projections. At +present only tan, sin, and arc are fully supported. In general +this involves changing parameter file constraints and documentation. diff --git a/pkg/images/tv/Revisions b/pkg/images/tv/Revisions new file mode 100644 index 00000000..51c49bd5 --- /dev/null +++ b/pkg/images/tv/Revisions @@ -0,0 +1,996 @@ +.help revisions Jun88 images.tv +.help revisions Nov93 nmisc +.nf + +tv/imedit/epstatistics.x + The 'x', 'y', and 'z' pointers were declared as TY_INT instead of TY_REAL + (5/4/13, MJF) + +imexamine/imexam.h + The coordinates arrays in the main structure were improperly indexed + with the P2R macro (2/10/11, MJF) + +imexamine/t_imexam.x + Removed some accidental code that was causing the frame number to + be prompted for. (12/4/08, MJF) + +display/t_display.x + The change of 8/16/07 results in the ocolors parameter being used + in place of the bpcolors parameter. + (8/26/08, Valdes) + +display/dspmmap.x + This was originally a copy of the code from xtools. This is now a + simple interface calling yt_mappm. This supports the new WCS + pixel mask matching. + (1/9/08, Valdes) + +============= +V2.12.4-V2.14 +============= + +doc/bpmedit.hlp +doc/imedit.hlp +imedit/bpmedit.cl +imedit/bpmedit.key +imedit/epcolon.x +imedit/epix.h +imedit/epmask.x +imedit/epreplace.gx +imedit/epreplace.x +imedit/epsetpars.x +imedit/imedit.key + Added new parameters to specify a range of values that may be modified. + This is mainly useful with bpmedit to selected mask values to be + modified. (11/16/07, Valdes) + + +display/maskcolor.x +display/t_display.x +display/ace.h +display/mkpkg +doc/display.hlp + The overlay colors may now be set with expressions as well as with + the earlier syntax. (8/16/07, Valdes) + + +imedit/bpmedit.cl + +doc/bpmedit.hlp + +./imedit/bpmedit.key + +tv.cl +tv.hd + A new script task for editing masks using imedit as the editing + engine was added. (8/9/07, Valdes) + +imedit/t_imedit.x +imedit/epgcur.x +./imedit/epreplace.gx + +./imedit/imedit.key + +doc/imedit.hlp +mkpkg +tv.cl + 1. A new option to do vector constant replacement was added. This is + particularly useful for editing bad pixel masks. + 2. New options '=', '<', and '>' to replace all pixels with values + ==, <=, or >= to the value at the cursor with the constant value + was added. This is useful for editing object masks. + 3. The '?' help page is now set by an environment variable rather than + hardcoded to a file in lib$src. The environment variable is + imedit_help and is set in tv.cl to point to the file in the + source directory. + (8/9/07, Valdes) + +pkg/images/tv/display/maskcolor.x + There was an error that failed to parse the color string as required. + (8/10/07, Valdes) + +pkg/images/tv/display/sigm2.x + Buffers were allocated as TY_SHORT but used and TY_INT. (8/9/07, Valdes) + +pkg/images/tv/display/t_display.x +pkg/images/tv/display/maskcolors.x +pkg/images/tv/display/sigl2.x +pkg/images/tv/display/sigm2.x +pkg/images/tv/doc/display.x + 1. Overlay masks are now read as integer to preserve dynamic range. + 2. Mapped color values less than 0 are transparent. + 3. A color name of transparent is allowed. + (4/10/07, Valdes) + +======= +V2.12.2 +======= + +pkg/images/tv/display/t_display.x + The image may be specified as a template provided it match only one + image. (9/11/03, Valdes) + +pkg/images/tv/imexamine/stfmeasure.x + The selection of a point to get a first estimation of the FWHM in + stf_fit did not check for the case of a zero value. This could cause + a floating divide by zero. (5/5/03, Valdes) + +pkg/images/tv/imexamine/stfmeasure.x + The subpixel evaluation involves fitting an image interpolator to a + subraster. To avoid attempting to evaluate a point outside the center + of the edge pixels, which is a requirement of the image interpolators, + the interpolator is fit to the full data raster and the evaluations + exclude the boundary pixels. (5/5/03, Valdes) + +pkg/images/tv/imexamine/iegnfr.x + The test for the number of frames needed to check imd_wcsver to avoid + trying to use more than four frames with DS9. (1/24/03, Valdes) + +pkg/images/tv/imexamine/t_imexam.x + Added some missing braces so that if a display is not used it doesn't + check for the number of frames to use. This is only cosmetic at this + time. (1/24/03, Valdes) + +======= +V2.12.1 +======= + +pkg/images/tv/doc/display.hlp + Clarified what "non-zero" means in the context of masks and images + used as masks. (7/29/02, Valdes) + +pkg/images/tv/display/t_display.x + Removed an unused extern declaration for ds_errfcn() which was causing + a link failure on the alpha (6/12/02, MJF) + +pkg/images/tv/tvmark/mktools.x +pkg/images/tv/tvmark/mkoutname.x + Fixed a bug in the default output image name code that would result in + hidden images with names like .snap.1, .snap.2, etc being written + if the display image name included a kernel or pixel section. + Davis (3/21/02) + +pkg/images/tv/display/t_display.x +pkg/images/tv/display/imdmapping.x + Added a check for the image name being "dev$pix" and if so prevented + this from being expanded to the full node!prefix pathname. Previously + the WCS would be written with a path like 'tucana!/iraf/iraf/dev/pix' + and would trigger an ambiguous image name error in clients like IMEXAM + which need to readback the image name with a WCS query. (3/4/02, MJF) + +pkg/images/tv/imexamine/iegimage.x + When imexmaine fails to map the image name returned by the display + server it uses the frame buffer. Previously there was no warning + message about failing to map the image. Now there is a warning. + This is only given once until there is no error or the error message + changes either by going to a new frame buffer or doing a new display. + (3/4/02, Valdes) + +pkg/images/tv/imexamine/iegimage.x +pkg/images/tv/imexamine/t_imexam.x + When the frame buffer is used as the image source (when the image name + in the display frame cannot be mapped) the final imunmap would + attempt to unmap the same descriptor twice. (3/1/02, Valdes) + +pkg/images/tv/imexamine/iegimage.x + The 'p' was not properly updated for the multiple WCS changes. + (2/26/02, Valdes) + +pkg/images/tv/imexamine/iegimage.x + The changes to support multiple WCS per frame involved keeping track of + the full WCS frame id (i.e. 101) rather than just the frame number. + There was a minor error in this bookkeeping when incrementing the + the next display frame to be used. (2/19/02, Valdes) + +pkg/images/tv/display/sigm2.x + The routine to compute the maximum value as the interpolated quantity + was incorrect because the size of the input and output arrays were + treated as the same when they are not. This is used for overlay + display which produced the symptom of horizontal lines. (2/5/02, Valdes) + +pkg/images/tv/display/dspmmap.x + Added the feature that the bad pixel mask or overlay mask may be + specified by a keyword value with the syntax !. This is + important for multiextension files where various masks are set + as keywords. The new task OBJMASKS also writes the object mask name + that is created for an image in the header. Use of !objmask then + allows the object mask to be used for the bad pixel mask (to set + the scaling using only sky pixels) and for overlay. (2/5/02, Valdes) + +pkg/images/tv/imedit/epimcopy.x + Added a missing TY_USHORT branch to the image copy routines. + (10/10/01, LED) + +pkg/images/tv/display/imdgetwcs.x +pkg/images/tv/display/imdputwcs.x +pkg/images/tv/display/imdsetwcs.x + Modified to allow read/write of the additional mapping information + during WCS i/o. If the iis_version flag is non-zero and a valid mapping + exists, the set/put wcs routines will automatically format the WCS text + to include this information, otherwise it writes the old WCS text. If + iis_version is non-zero and a server query returns mapping information + this will be stored in the iis common for later retrieval by the + imd_getmapping() routine. (06/21/01, MJF) + +pkg/images/tv/display/imdwcsver.x + Removed 'frame' number argument form the procedure. The procedure + will now map frame one if no connection is already opened and query the + WCS. Returns non-zero if the server is capable of using the new mapping + structures. Required to be called explicitly by programs using mappings + to initialize the imd interface for this functionality. (06/21/01, MJF) + +pkg/images/tv/display/t_display.x + Removed earlier addition of ds_setwcs() function since this is now + handled by the standard imd_putwcs() interface. Mapping information + is set prior to the WCS write with imd_setmapping(). (06/21/01, MJF) + +pkg/images/tv/display/mkpkg + Updated dependencies (06/21/01, MJF) + +pkg/images/tv/display/imdmapping.x + + New routines imd_[sg]etmapping() allow a program to set the + mapping to be sent with the next imd_putwcs() call, or retrieve the + mapping info sent by the server with the last wcs query. The calls + are no-ops if the connected server doesn't know about the new + mappings, imd_getmapping() is an integer function which returns + non-zero if a valid mapping is available. A new imd_query_map() is + available to return the mapping information for a given WCS number. + The intent is that the mapping can be obtained for a wcs returned by a + cursor read, e.g. to get the image name associated with the mapping. + (6/21/01, MJF) + +pkg/images/tv/display/iis.com + Added new variables to the IIS common to hold the mapping + information for each WCS write. In order to preserve the imd interfaces + it was necessary to save the mappings in the common, along with a flag + indicating whether the connected server can use them. (06/21/01, MJF) + +pkg/images/tv/display/iisopn.x + Added initialization of the iis_version value at device open time + (6/21/01, MJF) + +pkg/images/tv/display/gwindow.h + Removed struct element W_WCSVER added earlier, no longer needed. + (6/21/01, MJF) + +pkg/images/tv/display/t_display.x + Replaced call to alogr with direct call to log10 to avoid having to + define and error function for the vops operator. (6/15/01, Valdes) + +pkg/images/tv/display/sigm2.x + Removed extra arguments in amaxr call. (6/15/01, Valdes) + +pkg/images/tv/display/dspmmap.x + Added missing arguments to mw_ctrand. (6/15/01, Valdes) + +pkg/images/tv/display/dspmmap.x + Fixed problems with ds_match. The new version is more robust and + correct. A bad pixel for the displayed image is the maximum of all + pixels in the pixel mask which fall within the display pixel. This + version still does not allow any relative rotations but does allow + non-integer offsets. (4/24/01, Valdes) + +pkg/images/tv/display/t_display.x +pkg/images/tv/display/imdgetwcs.x +pkg/images/tv/display/imdwcsver.x +pkg/images/tv/display/iis.h + Compatability fixes for the new WCS strings and "old" servers. The + WCS version query is now carried out with a read request using the old + WCS data size (320) to avoid blocked reads from old servers not sending + the 1024-char data. imd_getwcs() was modified to query the server for + the version before the actual wcs query and the request is made with the + appropriate size. In the case of a WCS query the IIS 'x' register is + used to signal that the new format is being used, the WCS version is + passed back if the 'y' register is non-zero. Neither of these registers + was used by the old protocol, the new ximtool checks these registers and + responds by using the correct WCS buffer size. (03/12/01, MJF) + +pkg/images/tv/display/t_display.x + Removed the code which stripped the path-prefix and section from + the image name displayed in the title string. This was originally + done to save space but confuses tasks like IMEXAM which rely on + this to map the image. (02/26/01, MJF) + +pkg/images/tv/display/iis.h + Somehow the SZ_WCSTEXT value got reset to 320, this was causing + a problem with TVMARK redrawing the display. Reset to 1024. + (02/26/01, MJF) + +pkg/images/tv/display/t_display.x + Changes to detect and use new WCS strings (12/04/00, MJF) + +pkg/images/tv/display/gwindow.h + Added struct element W_WCSVER (12/04/00, MJF) + +pkg/images/tv/display/iis.h + Added definitions for 16-frame support, increased the size of + the SZ_WCSTEXT to 1024 (12/04/00, MJF) + +pkg/images/tv/display/mkpkg +pkg/images/tv/display/imdwcsver.x + + Added a routine which does a WCS query with the X register set + to check whether the server can handle the new WCS strings. If + the reply is "version=" we use the new stuff, otherwise it's + a no-op and we use the old format strings. (12/04/00, MJF) + +pkg/images/tv/display/t_display.x + Fixed an off-by-one error in WCS sent to the display when the display + buffer is smaller than the image. (9/5/00, Valdes) + +pkg/images/tv/imexamine/t_imexam.x +pkg/images/tv/imexamine/timexam.x + +pkg/images/tv/imexamine/iecolon.x +pkg/images/tv/imexamine/mkpkg +pkg/images/tv/imexamine.par +pkg/images/tv/doc/imexamine.hlp +lib/scr/imexamine.key + Added new key 't' to ouput an image section centered on the cursor. + (9/2/00, Valdes) + +pkg/images/tv/display/dspmmap.x + Masks were being copied internally in short which would truncate masks + having larger values. (5/16/00, Valdes) + +========= +V2.11.3p2 +========= + +pkg/images/tv/imedit/t_imedit.x +pkg/images/tv/imedit/epimcopy.x + Added some errchks. In particular, even though the output and working + images can be mapped without an error there could be an error in the + first I/O as when the imdir directory is not available/writeable. + (1/18/00, Valdes) + +pkg/images/tv/imedit/t_imedit.x + The use of a temporary image causes the output image type to be + set by "imtype" instead of any explicit extension. Changed to + use the xt_mkimtemp routine which tries to create a temporary image + of the desired output image type. (10/1/99, Valdes) + +pkg/images/tv/display/mkpkg +pkg/images/tv/wcslab/mkpkg +pkg/images/tv/imedit/mkpkg +pkg/images/tv/imexamine/mkpkg + Added some missing file dependencies and removed some unecessary ones + from the package mkpkg files. + (9/21/99 LED) + +pkg/images/tv/wcslab/wcslab.h + Added an entry for tnx to the list of supported projection types. + tnx image sometimes produced garbled plots, especially for ra ~0.0. + (9/17/99 LED) + +pkg/images/tv/wcslab/t_wcslab.x +pkg/images/tv/wcslab/wcslab.x + Fixed a couple of bugs in the wcslab task that were causing it to fail with + the message "ERROR: MWCS: coordinate system not defined (physical)" on the + Dec Alpha when the usewcs parameter was set to yes, and on Sun systems when + the input image was undefined. The problems were a bad call to the + routine mw_swtype in the routine wl_decode_ctype and a missing check + for the image = "" case. (8/28/99 LED) + +======= +V2.11.2 +======= + +images$tv/display/sigm2.x + An argument to sigm2_setup was being changed by the routine and this + changed argument was then incorrectly used by the calling program. + The argument was made input only. (6/15/99, Valdes) + +images$tv/imexamine/iepos.x + The output of the 'x' and 'y' keys was not being written to the log + file because of a typo. (5/7/99, Valdes) + +images$tv/display/t_display.x + Added checks for a data range of zero, or which rounds to zero for + short data, to avoid floating divide by zero errors. Rather than + resort to a unitary transformation in this case the requested + data range minimum is decreased by one and the maximum is increased + by one. (8/11/98, Valdes) + +images$tv/imexamine/stfmeasure.x + The logic in STF_FIT for determining the points to fit and the point + to use for the initial width estimate was faulty allowing some bad + cases to get through. (7/31/98, Valdes) + +images$tv/imedit/epix.h +images$tv/imedit/t_imedit.x +images$tv/imedit/epcolon.x +images$tv/doc/imedit.hlp + The temporary editing buffer image was made into a unique temporary + image rather than the fixed name of "epixbuf". (6/30/98, Valdes) + +======= +V2.11.1 +======= + +images$tv/imexamine/iepos.x + Added missing argument in fprintf call. (8/29/97, Valdes) + +images$tv/display/dspmmap.x + There was a bug in the code which gives "Warning: PLIO: reference out + of bounds on mask". This was introduced with the changes to allow + masks and images to have different binning. (8/21/97, Valdes) + +images$tv/imexamine/ieqrimexam.x + +images$tv/imexamine/t_imexam.x +images$tv/imexamine/iegcur.x +images$tv/imexamine/iecolon.x +images$tv/doc/imexamine.hlp +lib/scr/imexamine.key + Added two new keystrokes, ',' and '.', that do what 'a' and 'r' do + except they don't do the enclosed flux and direct FWHM measurements nor + iterate on the fitting radius. Also the output format is the same as + the previous version of IMEXAM. (6/12/97, Valdes) + +images$tv/imexamine/stfmeasure.x + 1. The background is now set to zero if there are no background points. + 2. Fixed an error recovery bug (attempting to free a pointer which + was not set). + (6/11/97, Valdes) + +images$tv/imexamine/ierimexam.x + The background widths needed to be passed to the PSF measuring routines + even if the background is turned off for the fitting in the 'a' and 'r' + keys. (6/11/97, Valdes) + +images$tv/doc/display.hlp + Added some more information about the colors. (5/30/97, Valdes) + +images$tv/display/dspmmap.x + Improved to allow different binning between masks and images. + (5/21/97, Valdes) + +images$tv/display/zscale.x + Fixed to work with 1D images. (5/21/97, Valdes) + +images$tv/display/zscale.x +images$tv/display/dspmmap.x + 1. Now works with higher dimensional images (displays the first band) + and with image sections. + 2. Now ignores error when the image has an unknown WCS type. The + WCS is mapped to determine the physical coordinate transformation + for use with masks but this failed when someone imported an image + with the CAR projection type. (4/30/97, Valdes) + +images$tv/doc/imexamine.hlp + Reversed the order of the version and task in the revisions section. + (4/22/97, Valdes) + +images$tv/tvmark/mkmark.x + Made sure that object the label was set to "" in the call to the + mk_onemark procedure inside the a keystroke command. The lack + of initialization was causing tvmark to fail when the coordinates + file did not exist at task startup time and the label parameter + was set to "yes". (4/17, LED) + +images$tv/imedit/epgsfit.x + The earlier change failed to setup the x/y arrays for the surface fitting. + This was fixed. (4/15/97, Valdes) + +images$tv/imexamine/iejimexam.x +images$tv/imexamine/iecolon.x +images$tv/kimexam.par + +images$tv/doc/imexamine.hlp +images$tv/tv.cl + Added a pset for the 'k' key rather than sharing with the 'j' key. This + was confusing to users since it was the only key without it's own pset. + Also there may be some reason to have the fitting parameters be + different along lines and columns. (4/11/97, Valdes) + +images$tv/imexamine/ierimexam.x +images$doc/imexamine.hlp + The log output for 'a' or 'r' has one line per measurement as in + previous versions. The standard output, however, uses two lines to + print nicely on 80 column windows. (4/1/97, Valdes) + +images$tv/rimexam.par +images$tv/doc/imexamine.hlp + Changed the zero point of the magnitude scale from 30.0 to 25.0. + (3/31/97, Davis) + +images$tv/display.par +images$tv/display/t_display.x +images$tv/display/zscale.x +images$tv/display/sigm2.x + +images$tv/display/maskcolor.x + +images$tv/display/dspmmap.x + +images$tv/display/display.h +images$tv/display/gwindow.h +images$tv/display/mkpkg +images$tv/doc/display.hlp + 1. Improved the structure of DISPLAY. + 2. Fixed coordinate system errors. + 3. Added parameters to display bad pixel masks and overlay masks. + 4. The z scaling sampling may use a pixel mask or image section. + 5. The z scaling excludes bad pixels. + (3/20/97, Valdes) + +images$tv/display/imdmapfr.x +images$tv/display/imdputwcs.x + + Added two routines to hide knowledge of the channel structure and + other details from the calling routines. (12/11/96, Valdes) + +images$tv/display/iishdr.x +images$tv/display/iisers.x + Replaces SPP int -> short assignments by calls to achtiu because of + overflow problems with some VMS fortran compilers. + (12/6/96, Valdes as reported by Zarate) + +images$tv/display/t_display.x + 1. Fixed numerous problems with the coordinate system. + 2. Fixed a bug in how ztrans=log was done. + (12/5/96, Valdes) + +images$tv/display/sigm2.x + + Added a version of the spatial interpolation routines that allows masks + to interpolate the input across bad pixels. (12/5/96, Valdes) + +images$tv/imedit/epgsfit.x +images$tv/imedit/epcolon.x +images$tv/doc/imedit.hlp +images$tv/imedit/imedit.par + Added a median background if the xorder or yorder is zero. + (11/22/96, Valdes) + +wcslab$t_wcslab.x +doc$wcslab.hlp + Added an "overplot" option to append to a plot but with a different + viewport. (11/06/96, Valdes) + +images$tv/imexamine/ierimexam.x + No change but the date got updated. (10/14/96, Valdes) + +images$tv/imexamine/stfmeasure.x + Fixed bug in evaluation of enclosed flux profile in which the scaled + radius was used for the gaussian subtraction stage instead of pixels. + This does not currently affect IMEXAM because the scale is fixed + at 1. (8/29/96, Valdes) + +images$tv/doc/imexamine.hlp + Removed reference to pset for kimexam. (5/31/96, Valdes) + +images$tv/imexamine/ierimexam.x +images$tv/imexamine/stfmeasure.x + Fixed incorrect datatype declaration "real np" -> "int np" in various + related places. (4/9/96, Valdes) + +images$tv/imedit/epsearch.x +images$tv/imedit/epgcur.x + 1. The search algorithm produced incorrect results if part of the aperture + was off the edge (negative image coordinates). + 2. The rounding was incorrect when part of the aperture was off the + edge (negative image coordinates). + 3. A floating operand error occurs when a key is given without + coordinates. + (3/26/96, Valdes) + +images$tv/imexamine/iecolon.x +images$tv/imexamine/starfocus.h +images$tv/imexamine/stfmeasure.x +images$tv/imexamine/ierimexam.x +images$tv/rimexam.par +images$doc/imexamine.hlp +lib$scr/imexamine.key + The radial profile fitting and width measurements now have an option to + use a Gaussian or Moffat profile model. The model is selected by a + new "fittype" parameter. A new "beta" parameter may be specified as + INDEF to be determined from the fit or have a fixed value. The Moffat + profile model does better in producing consistent FWHM values so + this is the default. There is also a new "iterations" parameter + to allow iteratively adjusting the fitting radius. + The STARFOCUS code used to compute other parameters was updated to + use a Moffat model and a new method for measuring the FWHM directly + from the radially average profile. (3/22/96, Valdes) + +images$tv/rimexam.par +images$tv/doc/imexamine.hlp + Changed the defaults to radius=5, buffer=5, width=5. A related change + is being made to STARFOCUS, PSFMEASURE, KPNOFOCUS to attempt to + produce similar values by default. (3/13/96, Valdes) + +images$tv/imexamine/iejimexam.x +images$tv/jimexam.par +images$tv/doc/imexamine.hlp + Bug 330: There were several errors in this which only show up when + using a world WCS. The parameter prompt and help now indicate the + initial sigma value is in pixels even when fitting in world + coordinates. (2/27/96, Valdes) + +images$tv/imexamine/iemw.x + The inverse WCS function was incorrect and is fixed. (2/27/96, Valdes) + +images$tv/imexamine/ierimexam.x +images$tv/imexamine/stfmeasure.x + +images$tv/imexamine/starfocus.h + +images$tv/imexamine/mkpkg +images$tv/doc/imexamine.hlp +lib$src/imexamine.key + New FWHM estimates based on the enclosed flux and a direct measurement + were added to the 'a' and 'r' keys. The weights for the Gaussian + fit were modified to reduce the influence of pixels outside the + half-maximum radius. The ? help and help page were revised to + described the new output and algorithms. (11/9/95+12/8/95+3/14/96, Valdes) + +images$tv/imedit/t_imedit.x +images$doc/imedit.hlp + The 'j', 'k', 'n', and 'u' keys were added to those recorded in the + logfile. (4/11/95, Valdes) + +images$doc/imexamine.hlp + Fixed a typo in the equation for ellipticity. (4/10/95, Valdes) + +images$tv/imexamine/iejimexam.x + Fixed a pointer addressing error found by Zarate. (2/16/95, Valdes) + +images$tv/imexamine/iecolon.x +images$tv/doc/imexamine.imh +lib$src/imexamine.key + 1. The "label" parameter was incorrectly attributed to the surface plot + instead of the contour plot. + 2. The "axes" parameter for the surface plot was missing in the code + though noted in the help. + 3. Updated the help and key file to show the label parameter belongs + to the e plot and to show the axes parameter. + (11/8/94, Valdes) + +images$tv/tvmark/mkmark.x + Replaced a seek to EOF call with a flush call in the the tvmark task add + object procedure. On SunOS systems the seek to EOF was apparently forcing + the flush while on Solaris systems it was not, resulting in the added + objects never being written to the coordinate file. + (10/3/94, Davis) + +images$tv/imexamine/ierimexam.x + World coordinates printed in the 'r' profile graph are now formated. + (8/2/94, Valdes) + +images$tv/wcslab/wcslab.x + Fixed an initialization bug in wcslab that was causing the axis labels + of the plot to be drawn incorrectly the first time wcslab was run. + This was only a bug under 2.10.3 + (26/7/94 Davis) + +images$tv/imexamine/iestatistics.x + Changed the statistics routine to compute quantities in double precision. + (3/10/93, Valdes) + +images$tv/imexamine/ierimexam.x +images$tv/doc/imexamine.hlp + The simple gaussian fitting was inadequate and gave biased answers. + Replaced this algorithm with NLFIT version. It is still just a two + parameter fit with the center and sky being determined and then fixed + as before. (3/2/93, Valdes) + +images$tv/wcslab/wcslab.h +images$tv/wcslab/wcs_desc.h +images$tv/wcslab/wcslab.x +images$tv/wcslab/wlwcslab.x + Removed a dependency on the file gio.h from the wcslab task. + (2/11/93 LED) + +images$tv/wcslab/wcs_desc.h +images$tv/wcslab/wcslab.h +images$tv/wcslab/wcslab.x +images$tv/wcslab/wlwcslab.x + Removed several dependences on the file gio.h which were no longer + required. There is still one remaining dependency. (2/11/93, Davis) + +images$tv/wcslab/wcslab.x + Fixed a bug in the axis mapping code in wcslab which was causing the + task to fail in some circumstances if the input image was a section + of a higher dimensioned parent image. (1/28/93, Davis) + +======= +V2.10.2 +======= + +images$imexamine/iejimexam.x + Changed aint to nint. (8/10/92, Valdes) + +images$imexamine/iegdata.x + For some reason (typo?) the test for out-of-bounds pixels was such that + a single column or line at the edge of the image was considered out of + bounds. The >= test was changed to >. (7/31/92, Valdes) + +======= +V2.10.1 +======= + +======= +V2.10.0 +======= + +======= +V2.10 +======= + +images$*imexam.par +images$imexamine/* +images$doc/imexamine.e + Made modifications to use coordinate formating in graphs and in + cursor readback. Also the WCS label will be used if label="wcslabel". + Two paramters were added to the main PSET, xformat and yformat. + (4/10/92, Valdes) + +images$tv/wcslab.x + Wcslab was failing if an image larger than the frame buffer was + displayed with fill=no. + (3/25/92, Davis) + +images$tv/imexamine/iemw.x + The logical coordinate of an excluded axis is 1 and not axval+1. + (3/9/92, Valdes) + +images$tv/wcslab/wlwcslab.x + Replaced the routine wl_unused_wcs which searched for an unused wcs + with some code to save and replace the current wcs. + + (2/18/92, Davis) + +images$tv/ + Moved all the .keys files from the noao$lib/scr/ and proto$tvmark/ + directories to the iraf$lib/scr/ directory. + + (1/29/92, Davis) + +images$tv/wcslab/ + Added the new task WCSLAB developed at ST by Jonathan Eisenhammer + and modified at NOAO to the TV package. + + (1/24/92, Davis) + +images$tv/ + + New version of the TV package created. + + The IMEDIT, IMEXAMINE, and TVMARK tasks were removed from the old + NOAO.PROTO package and added to the IMAGES.TV package. See below + for list of previous revisions to these tasks. + + The IIS dependent tasks BLINK, CV, CVL, ERASE, FRAME, LUMATCH, + MONOCHROME, PSEUDOCOLOR, RGB, WINDOW and ZOOM were removed from + the TV package and placed in the new subpackage TV.IIS. + + The directory structure of the IIS package was modified. + + (1/24/92, Davis) + +====================== +Package reorganization +====================== + +noao$proto/ +proto$imexamine/ievimexam.x + Corrected an error in the column limits computation in the routine + ie_get_vector that caused occasional glitches in vectors plotted + using the 'v' key. This bug may also explain occasional unrepeatable + bus errors which occurred after using the 'v' key. (12/11/91, Davis) + +proto$imedit/epcolon.x + Two calls to pargr changed to pargi. (11/13/91, Valdes) + +proto$tvmark/t_tvmark.x +proto$tvmark/mkcolon.x + Removed extra argument to mk_sets() calls. (11/13/91, Davis) + +proto$tvmark/mkppars.x + Changed two clputi calls to clputb calls. (11/13/91, Davis) + +proto$jimexam.par +proto$proto.cl +proto$mkpkg +proto$imexamine/iejimexam.x +proto$imexamine/iecolon.x +proto$imexamine/t_imexam.x +proto$imexamine/iegcur.x +proto$imexamine/mkpkg +proto$doc/imexamine.hlp +noao$lib/scr/imexamine.key + Added new options for fitting 1D gaussians to lines and columns. + (9/2/91, Valdes) + +proto$imexamine/iemw.x + +proto$imexamine/iecimexam.x +proto$imexamine/iecolon.x +proto$imexamine/iegimage.x +proto$imexamine/ielimexam.x +proto$imexamine/iepos.x +proto$imexamine/ierimexam.x +proto$imexamine/imexam.h +proto$imexamine/mkpkg +proto$imexamine/t_imexam.x +proto$imexamine.par +proto$doc/imexamine.hlp + Modified IMEXAMINE to use WCS information in axis labels and coordinate + readback. (8/13/91, Valdes) + +proto$tvmark/mkonemark.x + Moved the two salloc routines to the top of the mk_onemark routine + where they cannot be called more than once. + (7/22/91, Davis) + +proto$tvmark.par + Modified the description of the pointsize parameter. + (7/17/91, Davis) + +proto$imexamine/iesimexam.x + Add code for checking and warning if data is all constant, all above the + specified ceiling, or all below the specified floor when making surface + plots. (10/3/90, Valdes) + +proto$imedit/epmask.x + Added some protective changes so that if a radius of zero with a circular + aperture is used then round off will be less likely to cause missing + the pixel. (9/23/90, Valdes) + +proto$tvmark/tvmark.key +proto$tvmark/mkmark.x +proto$tvmark/doc/tvmark.hlp + At user request changed the 'd' keystroke command which marks an object + with a dot to the '.' and the 'u' keystroke command which deletes a + point to 'd'. (9/14/90 Davis) + +==== +V2.9 +==== + +noao$proto/imedit/epgcur.x + Valdes, June 6, 1990 + The fixpix format input was selecting interpolation across the longer + dimension instead of the shorter. This meant that complete columns + or lines did not work at all. + +==== +V2.8 +==== + +noao$proto/imexamine/t_imexam.x + Valdes, Mar 29, 1990 + Even when use_display=no the task was trying to check the image display + for the name. This was fixed by adding a check for this flag in the + relevant if statement. + +noao$proto/imexamine/ievimexam.x + Valdes, Mar 22, 1990 + The pset was being closed without indicating this in the data structure. + The clcpset statement was removed. + +noao$proto/imedit/epgcur.x + Valdes, Mar 15, 1990 + The EOF condition was being screwed up for two keystroke commands leading + to a possible infinite loop when using a cursor file input. The fix + is to change the "nitems=nitems+clgcur" incrementing to simply + "nitems=clgcur". + +noao$proto/imedit/epbackground.x +noao$proto/imedit/epgcur.x + Valdes, Mar 9, 1990 + 1. The surfit pointer was incorrectly declared as real in ep_bg causing the + 'b' key to do nothing. This appears to be SPARC dependent. + 2. Fixed some more problems with cursor strings having missing coordinates + causing floating overflow errors. + +noao$proto/imexamine/iecolon.x + Valdes, Feb 16, 1990 + Fixed a mistake in the the datatype of a parg call. + +noao$proto/imedit.par +noao$proto/imedit/epcolon.x +noao$proto/imedit/epmask.x + Valdes, Jan 17, 1990 + 1. Fixed typo in prompt string for y background order. + 2. Wrong datatype in clput for order parameters resulting in setting + the user parameter file value to 0. + 3. Bug fix in epmask. The following is the correct line: + line 130: call amovi (Memi[line], Memi[ptr2+i*EP_NX(ep)], EP_NX(ep)) + +noao$proto/imedit/epdisplay.x + Valdes, Jan 7, 1990 + Added initialization to the zoom state. Without the intialization + starting IMEDIT without display and then turning display on followed by + a 'r' would cause an error (very obscure but found in a demo). + +noao$proto/tvmark/t_tvmark.x +noao$proto/tvmark/mkmark.x +noao$proto/tvmark/tvmark.key +noao$proto/doc/tvmark.hlp + Valdes, Jan 4, 1990 + Added filled rectangle command 'f'. + +noao$proto/tvmark/t_tvmark.x +noao$proto/tvmark/mktools.x +noao$proto/tvmark/mkshow.x +noao$proto/tvmark/mkcolon.x +noao$proto/tvmark/mkfind.x +noao$proto/tvmark/mkremove.x + Davis, Dec 12, 1989 + 1. Tvmark has been modified to permit deletion as well as addition of + objects to the coordinate file. Objects to be deleted are marked + with the cursor and must be within a given tolerance of an + object in the coordinate list to be deleted. + 2. The help screen no longer comes up in the text window when the task + is invoked for the sake of uniformity with all other IRAF tasks. + 3. The coordinate file is opened read_only in batch mode. In interactive + mode a warning message is issued if the user tries to append or delete + objects from a file which does not have write permission and no action + is taken. + +noao$proto/imexamine/t_imexam.x +noao$proto/imexamine/iegimage.x + Valdes, Nov 30, 1989 + The default display frame when not using an input list was changed from + 0 to 1. + +noao$proto/imeidt/epgcur.x + Valdes, Oct 30, 1989 + 1. There was no check against INDEF cursor coordinates. Such coordinates + will occur when reading a previous logfile output and cursor input + where the shorthand ":command" is used. The actual error occured when + attempting to add 0.5 to INDEF. + +noao$proto/imedit/epstatistics.x +noao$proto/imedit/epmove.x +noao$proto/imedit/epgsfit.x +noao$proto/imedit/epnoise.x +noao$proto/imedit/epbackground.x +noao$proto/imedit/t_imedit.x + Valdes, Aug 17, 1989 + 1. Added errchk to main cursor loop to try and prevent loss of the + user's changes if an error occurs. + 2. If no background points are found an error message is now printed + instead of aborting. + +noao$proto/tvmark/mkbmark.x + Davis, Aug 4, 1989 + Modified tvmark so that drawing to the frame buffer is more efficient + in batch mode. This involved removing a number of imflush calls + which were unnecessarily flushing the output buffer to disk and + recoding the basic routines which draw concentric circles and rectangles. + +=========== +Version 2.8 +=========== + +noao$proto/imexamine/* + +noao$proto/imexamine.par + +noao$proto/?imexam.par + +noao$proto/doc/imexamine.hlp + +noao$proto/proto.cl +noao$proto/proto.men +noao$proto/proto.hd +noao$proto/x_proto.x +noao$proto/mkpkg +noao$lib/scr/imexamine.key + Valdes, June 13, 1989 + New task IMEXAMINE added to the proto package. + +noao$proto/tvmark/ + Davis, June 6, 1989 + Fixed a bug in tvmark wherein circles were not being drawn if they + were partially off the image in the x dimension. + +noao$proto/tvmark/ + Davis, June1, 1989 + A labeling capability has been added to tvmark. If the label parameter + is turned on tvmark will label objects with the string in the third + column of the coordinate file. + +noao$proto/tvmark/ + Davis, May 25, 1989 + The problem reported by phil wherein TVMARK would go into an infinite + loop if it encountered a blank line has been fixed. + +noao$proto/tvmark + Davis, May 22, 1989 + The new task TVMARK was added to the proto package. + +noao$proto/imedit/ + Davis, May 22, 1989 + The new task IMEDIT was added to the proto package. + +====================== +Package reorganization +====================== + +=========== +Release 2.2 +=========== +.endhelp diff --git a/pkg/images/tv/_dcontrol.par b/pkg/images/tv/_dcontrol.par new file mode 100644 index 00000000..451548c6 --- /dev/null +++ b/pkg/images/tv/_dcontrol.par @@ -0,0 +1,18 @@ +type,s,h,frame,,,"Display type (frame, rgb)" +map,s,h,mono,,,"Display map (mono, psuedo, 8color, cycle)" +red_frame,i,h,1,1,4,Red frame +green_frame,i,h,2,1,4,Green frame +blue_frame,i,h,3,1,4,Blue frame +frame,i,h,1,1,4,Display frame +alternate,s,h,0,,,Alternate frame or frames +erase,b,h,no,,,Erase display +window,b,h,no,,,Window display frame +rgb_window,b,h,no,,,Window RGB frames +cursor,b,h,no,,,Print cursor position +blink,b,h,no,,,Blink display frame with alternate frame +match,b,h,no,,,Match display frame window with alternate frame +roam,b,h,no,,,Roam display +zoom,i,h,2,1,4,Zoom factor +rate,r,h,1.,,,Blink rate (sec per frame) +coords,*imcur,h,,,,Coordinate list +device,s,h,"stdimage",,,Display device diff --git a/pkg/images/tv/cimexam.par b/pkg/images/tv/cimexam.par new file mode 100644 index 00000000..bbba22c8 --- /dev/null +++ b/pkg/images/tv/cimexam.par @@ -0,0 +1,22 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"wcslabel",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" + +naverage,i,h,1,,,Number of columns to average +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,no,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/display.par b/pkg/images/tv/display.par new file mode 100644 index 00000000..04001e8c --- /dev/null +++ b/pkg/images/tv/display.par @@ -0,0 +1,30 @@ +# Parameter file for DISPLAY + +image,f,a,,,,image to be displayed +frame,i,a,1,1,4,frame to be written into +bpmask,f,h,"BPM",,,bad pixel mask +bpdisplay,s,h,"none","none|overlay|interpolate",,bad pixel display (none|overlay|interpolate) +bpcolors,s,h,"red",,,bad pixel colors +overlay,f,h,"",,,overlay mask +ocolors,s,h,"green",,,overlay colors +erase,b,h,yes,,,erase frame +border_erase,b,h,no,,,erase unfilled area of window +select_frame,b,h,yes,,,display frame being loaded +repeat,b,h,no,,,repeat previous display parameters +fill,b,h,no,,,scale image to fit display window +zscale,b,h,yes,,,display range of greylevels near median +contrast,r,h,0.25,,,contrast adjustment for zscale algorithm +zrange,b,h,yes,,,display full image intensity range +zmask,f,h,"",,,sample mask +nsample,i,h,1000,100,,maximum number of sample pixels to use +xcenter,r,h,0.5,0,1,display window horizontal center +ycenter,r,h,0.5,0,1,display window vertical center +xsize,r,h,1,0,1,display window horizontal size +ysize,r,h,1,0,1,display window vertical size +xmag,r,h,1.,,,display window horizontal magnification +ymag,r,h,1.,,,display window vertical magnification +order,i,h,0,0,1,"spatial interpolator order (0=replicate, 1=linear)" +z1,r,h,,,,minimum greylevel to be displayed +z2,r,h,,,,maximum greylevel to be displayed +ztrans,s,h,linear,,,greylevel transformation (linear|log|none|user) +lutfile,f,h,"",,,file containing user defined look up table diff --git a/pkg/images/tv/display/README b/pkg/images/tv/display/README new file mode 100644 index 00000000..f31a6aa4 --- /dev/null +++ b/pkg/images/tv/display/README @@ -0,0 +1,15 @@ +DISPLAY -- Prototype routines for loading and controlling the image display. +The lower level code is device dependent. + + display loads the display + dcontrol adjusts the display (frame select, window, etc.) + +The basic strategy is that the image display device is interfaced to IRAF +file i/o as a binary file. IMIO is then used to access the image or graphics +planes of the device as a disk resident imagefile would be referenced. +Each image plane of each image device is a separate "imagefile", and has a +distinct image header file in the directory "dev$". + +This package uses the ZFIOGD (binary graphics device) device driver, the +source for which is in host$gdev. It is this driver which implements physical +i/o to the device (actually, to the host system device driver for the device). diff --git a/pkg/images/tv/display/ace.h b/pkg/images/tv/display/ace.h new file mode 100755 index 00000000..4c4f40bf --- /dev/null +++ b/pkg/images/tv/display/ace.h @@ -0,0 +1,38 @@ +define NUMSTART 11 # First object number + +# Mask Flags. +define MASK_NUM 000777777B # Mask number +define MASK_GRW 001000000B # Grow pixel +define MASK_SPLIT 002000000B # Split flag +define MASK_BNDRY 004000000B # Boundary flag +define MASK_BP 010000000B # Bad pixel +define MASK_BPFLAG 020000000B # Bad pixel flag +define MASK_DARK 040000000B # Dark flag + +define MSETFLAG ori($1,$2) +define MUNSETFLAG andi($1,noti($2)) + +define MNUM (andi($1,MASK_NUM)) +define MNOTGRW (andi($1,MASK_GRW)==0) +define MGRW (andi($1,MASK_GRW)!=0) +define MNOTBP (andi($1,MASK_BP)==0) +define MBP (andi($1,MASK_BP)!=0) +define MNOTBPFLAG (andi($1,MASK_BPFLAG)==0) +define MBPFLAG (andi($1,MASK_BPFLAG)!=0) +define MNOTBNDRY (andi($1,MASK_BNDRY)==0) +define MBNDRY (andi($1,MASK_BNDRY)!=0) +define MNOTSPLIT (andi($1,MASK_SPLIT)==0) +define MSPLIT (andi($1,MASK_SPLIT)!=0) +define MNOTDARK (andi($1,MASK_DARK)==0) +define MDARK (andi($1,MASK_DARK)!=0) + +# Output object masks types. +define OM_TYPES "|boolean|numbers|colors|all|\ + |bboolean|bnumbers|bcolors|" +define OM_BOOL 1 # Boolean (0=sky, 1=object+bad+grow) +define OM_ONUM 2 # Object number only +define OM_COLORS 3 # Bad=1, Objects=2-9 +define OM_ALL 4 # All values +define OM_BBOOL 6 # Boolean (0=sky, 1=object+bad+grow) +define OM_BONUM 7 # Object number only +define OM_BCOLORS 8 # Bad=1, Objects=2-9 diff --git a/pkg/images/tv/display/display.h b/pkg/images/tv/display/display.h new file mode 100644 index 00000000..fa89a479 --- /dev/null +++ b/pkg/images/tv/display/display.h @@ -0,0 +1,42 @@ +# Display modes: + +define RGB 1 # True color mode +define FRAME 2 # Single frame mode + +# Color selections: + +define BLUE 1B # BLUE Select +define GREEN 2B # GREEN Select +define RED 4B # RED Select +define MONO 7B # RED + GREEN + BLUE + +# Size limiting parameters. + +define MAXCHAN 2 +define SAMPLE_SIZE 600 + +# If a logarithmic greyscale transformation is desired, the input range Z1:Z2 +# will be mapped into the range 1.0 to 10.0 ** MAXLOG before taking the log +# to the base 10. + +define MAXLOG 3 + +# The following parameter is used to compare display pixel coordinates for +# equality. It determines the maximum permissible magnification. The machine +# epsilon is not used because the computations are nontrivial and accumulation +# of error is a problem. + +define DS_TOL (1E-4) + +# These parameters are needed for user defined transfer functions. + +define U_MAXPTS 4096 +define U_Z1 0 +define U_Z2 4095 + +# BPDISPLAY options: + +define BPDISPLAY "|none|overlay|interpolate|" +define BPDNONE 1 # Ignore bad pixel mask +define BPDOVRLY 2 # Overlay bad pixels +define BPDINTERP 3 # Interpolate bad pixels diff --git a/pkg/images/tv/display/dsmap.x b/pkg/images/tv/display/dsmap.x new file mode 100644 index 00000000..4a5f7e9c --- /dev/null +++ b/pkg/images/tv/display/dsmap.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# DSMAP -- Map the display, i.e., open the display device as an imagefile. + +pointer procedure dsmap (frame, mode, color, chan) + +int frame +int mode +int color +int chan[ARB] + +pointer ds +char device[SZ_FNAME] + +int imstati(), fstati(), envgets(), imdopen() +extern imdopen() +pointer imdmap() +errchk imdmap + +begin + if (envgets ("stdimage", device, SZ_FNAME) == 0) + call error (1, "variable `stdimage' not defined in environment") + + ds = imdmap (device, mode, imdopen) + chan[1] = fstati (imstati (ds, IM_PIXFD), F_CHANNEL) + chan[2] = color + + return (ds) +end diff --git a/pkg/images/tv/display/dspmmap.x b/pkg/images/tv/display/dspmmap.x new file mode 100644 index 00000000..e20689f1 --- /dev/null +++ b/pkg/images/tv/display/dspmmap.x @@ -0,0 +1,20 @@ +# DS_PMMAP -- Open a pixel mask READ_ONLY. + +pointer procedure ds_pmmap (pmname, refim) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer + +pointer sp, mname +pointer im, yt_mappm() +errchk yt_mappm + +begin + call smark (sp) + call salloc (mname, SZ_FNAME, TY_CHAR) + + im = yt_mappm (pmname, refim, "pmmatch", Memc[mname], SZ_FNAME) + + call sfree (sp) + return (im) +end diff --git a/pkg/images/tv/display/dsulut.x b/pkg/images/tv/display/dsulut.x new file mode 100644 index 00000000..2069bd68 --- /dev/null +++ b/pkg/images/tv/display/dsulut.x @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "display.h" + +# DS_ULUTALLOC -- Generates a look up table from data supplied by user. +# The data is read from a two column text file of intensity, greyscale values. +# The input data are sorted, then mapped to the x range [0-4095]. A +# piecewise linear look up table of 4096 values is then constructed from +# the (x,y) pairs given. A pointer to the look up table, as well as the z1 +# and z2 intensity endpoints, is returned. + +pointer procedure ds_ulutalloc (fname, z1, z2) + +char fname[SZ_FNAME] # Name of file with intensity, greyscale values +real z1 # Intensity mapped to minimum gs value +real z2 # Intensity mapped to maximum gs value + +pointer lut, sp, x, y +int nvalues, i, j, x1, x2, y1 +real delta_gs, delta_xv, slope +errchk ds_ulutread, ds_ulutsort, malloc + +begin + call smark (sp) + call salloc (x, U_MAXPTS, TY_REAL) + call salloc (y, U_MAXPTS, TY_REAL) + + # Read intensities and greyscales from the user's input file. The + # intensity range is then mapped into a standard range and the + # values sorted. + + call ds_ulutread (fname, Memr[x], Memr[y], nvalues) + call alimr (Memr[x], nvalues, z1, z2) + call amapr (Memr[x], Memr[x], nvalues, z1, z2, real(U_Z1), real(U_Z2)) + call ds_ulutsort (Memr[x], Memr[y], nvalues) + + # Fill lut in straight line segments - piecewise linear + call malloc (lut, U_MAXPTS, TY_SHORT) + do i = 1, nvalues-1 { + delta_gs = Memr[y+i] - Memr[y+i-1] + delta_xv = Memr[x+i] - Memr[x+i-1] + slope = delta_gs / delta_xv + x1 = int (Memr[x+i-1]) + x2 = int (Memr[x+i]) + y1 = int (Memr[y+i-1]) + do j = x1, x2 + Mems[lut+j] = y1 + slope * (j-x1) + } + Mems[lut+U_MAXPTS-1] = y1 + (slope * U_Z2) + + call sfree (sp) + return (lut) +end + + +# DS_ULUTFREE -- Free the lookup table allocated by DS_ULUT. + +procedure ds_ulutfree (lut) + +pointer lut + +begin + call mfree (lut, TY_SHORT) +end + + +# DS_ULUTREAD -- Read text file of x, y, values. + +procedure ds_ulutread (utab, x, y, nvalues) + +char utab[SZ_FNAME] # Name of list file +real x[U_MAXPTS] # Array of x values, filled on return +real y[U_MAXPTS] # Array of y values, filled on return +int nvalues # Number of values in x, y vectors - returned + +int n, fd +pointer sp, lbuf, ip +real xval, yval +int getline(), open() +errchk open, sscan, getline, salloc + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + iferr (fd = open (utab, READ_ONLY, TEXT_FILE)) + call error (1, "Error opening user lookup table") + + n = 0 + while (getline (fd, Memc[lbuf]) != EOF) { + # Skip comment lines and blank lines. + if (Memc[lbuf] == '#') + next + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Decode the points to be plotted. + call sscan (Memc[ip]) + call gargr (xval) + call gargr (yval) + + n = n + 1 + if (n > U_MAXPTS) + call error (2, + "Intensity transformation table cannot exceed 4096 values") + + x[n] = xval + y[n] = yval + } + + nvalues = n + call close (fd) + call sfree (sp) +end + + +# DS_ULUTSORT -- Bubble sort of paired arrays. + +procedure ds_ulutsort (xvals, yvals, nvals) + +real xvals[nvals] # Array of x values +real yvals[nvals] # Array of y values +int nvals # Number of values in each array + +int i, j +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + for (i=nvals; i > 1; i=i-1) + for (j=1; j < i; j=j+1) + if (xvals[j] > xvals[j+1]) { + # Out of order; exchange y values + swap (xvals[j], xvals[j+1]) + swap (yvals[j], yvals[j+1]) + } +end diff --git a/pkg/images/tv/display/findz.x b/pkg/images/tv/display/findz.x new file mode 100644 index 00000000..e1f0f73e --- /dev/null +++ b/pkg/images/tv/display/findz.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# FINDZ -- Estimate the range of greylevels Z1 to Z2 containing a specified +# fraction of the greylevels in the image. The technique is to sample the +# image at some interval, computing the values of the greylevels a fixed +# distance either side of the median. Since it is not necessary to compute +# the full histogram we do not need to know the image zmin, zmax in advance. +# Works for images of any dimensionality, size, or datatype. + +procedure findz (im, z1, z2, zfrac, maxcols, nsample_lines) + +pointer im +real z1, z2, zfrac +int maxcols, nsample_lines + +real rmin, rmax +real frac +int imin, imax, ncols, nlines +int i, n, step, sample_size, imlines + +pointer sp, buf +pointer imgl2r() +include "iis.com" + +begin + call smark (sp) + call salloc (buf, ncols, TY_REAL) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Try to include a constant number of pixels in the sample + # regardless of the image size. The entire image is used if we + # have a small image, and at least sample_lines lines are read + # if we have a large image. + + sample_size = iis_ydim * nsample_lines + imlines = min(nlines, max(nsample_lines, sample_size / ncols)) + step = nlines / (imlines + 1) + + frac = (1.0 - zfrac) / 2. + imin = frac * (ncols - 1) + imax = (1.0 - frac) * (ncols - 1) + rmin = 0.0 + rmax = 0.0 + n = 0 + + do i = 1 + step, nlines, max (1, step) { + call asrtr (Memr[imgl2r (im, i)], Memr[buf], ncols) + rmin = rmin + Memr[buf + imin] + rmax = rmax + Memr[buf + imax] + n = n + 1 + } + + z1 = rmin / n + z2 = rmax / n + + call sfree (sp) +end diff --git a/pkg/images/tv/display/gwindow.h b/pkg/images/tv/display/gwindow.h new file mode 100644 index 00000000..ae91e2ea --- /dev/null +++ b/pkg/images/tv/display/gwindow.h @@ -0,0 +1,49 @@ +# Window descriptor structure. + +define LEN_WDES (210+(W_MAXWC+1)*LEN_WC) +define LEN_WC 10 # 4=[XbXeYbYe]+2=tr_type[xy] +define W_MAXWC 5 # max world coord systems +define W_SZSTRING 99 # size of strings +define W_SZIMSECT W_SZSTRING # image section string + +define W_DEVICE Memi[$1] +define W_FRAME Memi[$1+1] # device frame number +define W_XRES Memi[$1+2] # device resolution, x +define W_YRES Memi[$1+3] # device resolution, y +define W_BPDISP Memi[$1+4] # bad pixel display option +define W_BPCOLORS Memi[$1+5] # overlay colors +define W_OCOLORS Memi[$1+6] # badpixel colors +define W_IMSECT Memc[P2C($1+10)] # image section +define W_OVRLY Memc[P2C($1+60)] # overlay mask +define W_BPM Memc[P2C($1+110)] # bad pixel mask +define W_ZPM Memc[P2C($1+160)] # Z scaling pixel mask +define W_WC ($1+$2*LEN_WC+210) # ptr to coord descriptor + +# Fields of the WC coordinate descriptor, a substructure of the window +# descriptor. "W_XB(W_WC(w,0))" is the XB field of wc 0 of window W. + +define W_XS Memr[P2R($1)] # starting X value +define W_XE Memr[P2R($1+1)] # ending X value +define W_XT Memi[$1+2] # X transformation type +define W_YS Memr[P2R($1+3)] # starting Y value +define W_YE Memr[P2R($1+4)] # ending Y value +define W_YT Memi[$1+5] # Y transformation type +define W_ZS Memr[P2R($1+6)] # starting Z value (greyscale) +define W_ZE Memr[P2R($1+7)] # ending Z value +define W_ZT Memi[$1+8] # Z transformation type +define W_UPTR Memi[$1+9] # LUT when ZT=USER + +# WC types. + +define W_NWIN 0 # Display window in NDC coordinates +define W_DWIN 1 # Display window in image pixel coordinates +define W_WWIN 2 # Display window in image world coordinates +define W_IPIX 3 # Image pixel coordinates (in pixels) +define W_DPIX 4 # Display pixel coordinates (in pixels) + +# Types of coordinate and greyscale transformations. + +define W_UNITARY 0 # values map without change +define W_LINEAR 1 # linear mapping +define W_LOG 2 # logarithmic mapping +define W_USER 3 # user specifies transformation diff --git a/pkg/images/tv/display/iis.com b/pkg/images/tv/display/iis.com new file mode 100644 index 00000000..8b367132 --- /dev/null +++ b/pkg/images/tv/display/iis.com @@ -0,0 +1,25 @@ +# Common for IIS display + +int iischan # the device channel used by FIO +int iisnopen # number of times the display has been opened +int iisframe # frame number at iisopn time (kludge). +int iis_xdim, iis_ydim # frame size, pixels +int iis_config # frame size configuration +int iis_server # device is actually a display server +bool packit # byte pack data for i/o +bool swap_bytes # byte swap the IIS header +short hdr[LEN_IISHDR] # header + +int iis_version # WCS version +int iis_valid # valid mapping info flag +char iis_region[SZ_FNAME] # region name +real iis_sx, iis_sy # source raster offset +int iis_snx, iis_sny # source raster size +int iis_dx, iis_dy # dest raster offset +int iis_dnx, iis_dny # dest raster size +char iis_objref[SZ_FNAME] # object reference + +common /iiscom/ iischan, iisnopen, iisframe, iis_xdim, iis_ydim, iis_config, + iis_server, packit, swap_bytes, hdr, iis_version, iis_valid, + iis_region, iis_sx, iis_sy, iis_snx, iis_sny, + iis_dx, iis_dy, iis_dnx, iis_dny, iis_objref diff --git a/pkg/images/tv/display/iis.h b/pkg/images/tv/display/iis.h new file mode 100644 index 00000000..bdd4f33a --- /dev/null +++ b/pkg/images/tv/display/iis.h @@ -0,0 +1,121 @@ +# This file contains the hardware definitions for the iis model 70/f +# at Kitt Peak. + +# Define header +define LEN_IISHDR 8 # Length of IIS header + +define XFERID $1[1] # transfer id +define THINGCT $1[2] # thing count +define SUBUNIT $1[3] # subuint select +define CHECKSUM $1[4] # check sum +define XREG $1[5] # x register +define YREG $1[6] # y register +define ZREG $1[7] # z register +define TREG $1[8] # t register + + +# Transfer ID definitions +define IREAD 100000B +define IWRITE 0B +define PACKED 40000B +define SAMPLE 40000B +define BYPASSIFM 20000B +define BYTE 10000B +define ADDWRITE 4000B +define ACCUM 2000B +define BLOCKXFER 1000B +define VRETRACE 400B +define MUX32 200B +define IMT800 100B # [IMTOOL SPECIAL] + +# Subunits +define REFRESH 1 +define LUT 2 +define OFM 3 +define IFM 4 +define FEEDBACK 5 +define SCROLL 6 +define VIDEOM 7 +define SUMPROC 8 +define GRAPHICS 9 +define CURSOR 10 +define ALU 11 +define ZOOM 12 +define IMCURSOR 20B +define WCS 21B + +# Command definitions +define COMMAND 100000B +define ADVXONTC 100000B # Advance x on thing count +define ADVXONYOV 40000B # Advance x on y overflow +define ADVYONXOV 100000B # Advance y on x overflow +define ADVYONTC 40000B # Advance y on thing count +define ERASE 100000B # Erase + +# 4 - Button Trackball +define PUSH 40000B +define BUTTONA 400B +define BUTTONB 1000B +define BUTTONC 2000B +define BUTTOND 4000B + +# Display channels +define CHAN1 1B +define CHAN2 2B +define CHAN3 4B +define CHAN4 10B +define CHAN5 20B +define CHAN6 40B +define CHAN7 100B +define CHAN8 200B +define CHAN9 400B +define CHAN10 1000B +define CHAN11 2000B +define CHAN12 4000B +define CHAN13 10000B +define CHAN14 20000B +define CHAN15 40000B +define CHAN16 100000B +define GRCHAN 100000B + +define LEN_IISFRAMES 16 +define IISFRAMES CHAN1, CHAN2, CHAN3, CHAN4, CHAN5, CHAN6, CHAN7, CHAN8, CHAN9, CHAN10, CHAN11, CHAN12, CHAN13, CHAN14, CHAN15, CHAN16 + +# Colors + +define BLUE 1B +define GREEN 2B +define RED 4B +define MONO 7B + +# Bit plane selections +define BITPL0 1B +define BITPL1 2B +define BITPL2 4B +define BITPL3 10B +define BITPL4 20B +define BITPL5 40B +define BITPL6 100B +define BITPL7 200B +define ALLBITPL 377B + +# IIS Sizes +define IIS_XDIM 512 +define IIS_YDIM 512 +define MCXSCALE 64 # metacode x scale +define MCYSCALE 64 # metacode y scale +define SZB_IISHDR 16 # size of IIS header in bytes +define SZB_IMCURVAL 160 # size of imcursor value buffer, bytes +define LEN_ZOOM 3 # zoom parameters +define LEN_CURSOR 3 # cursor parameters +define LEN_SPLIT 12 # split screen +define LEN_LUT 256 # look up table +define LEN_OFM 1024 # output function look up table +define SZ_OLD_WCSTEXT 320 # old max WCS text chars +define SZ_WCSTEXT 1024 # max WCS text chars + +# IIS Status Words +define IIS_FILSIZE (IIS_XDIM * IIS_YDIM * SZB_CHAR) +define IIS_BLKSIZE 1024 +define IIS_OPTBUFSIZE (IIS_XDIM * SZB_CHAR) +define IIS_MAXBUFSIZE 32768 diff --git a/pkg/images/tv/display/iisblk.x b/pkg/images/tv/display/iisblk.x new file mode 100644 index 00000000..1ff81d49 --- /dev/null +++ b/pkg/images/tv/display/iisblk.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISBLK -- Blink IIS display frames at millisecond time resolution. + +procedure iisblk (chan1, chan2, chan3, chan4, nframes, rate) + +int chan1[ARB] +int chan2[ARB] +int chan3[ARB] +int chan4[ARB] +int nframes +real rate + +int msec, status, xcur, ycur +int and() + +begin + status = 0 + msec = int (rate * 1000.) + + while (and (status, PUSH) == 0) { + call zwmsec (msec) + call iisrgb (chan1, chan1, chan1) + call zwmsec (msec) + call iisrgb (chan2, chan2, chan2) + if (nframes >= 3) { + call zwmsec (msec) + call iisrgb (chan3, chan3, chan3) + } + if (nframes == 4) { + call zwmsec (msec) + call iisrgb (chan4, chan4, chan4) + } + call iisrcr (status, xcur, ycur) + } +end diff --git a/pkg/images/tv/display/iiscls.x b/pkg/images/tv/display/iiscls.x new file mode 100644 index 00000000..71da6c35 --- /dev/null +++ b/pkg/images/tv/display/iiscls.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# IISCLS -- Close IIS display. + +procedure iiscls (chan, status) + +int chan[ARB] +int status +include "iis.com" + +begin + if (iisnopen == 1) { + call zclsgd (iischan, status) + iisnopen = 0 + } else if (iisnopen > 1) { + iisnopen = iisnopen - 1 + } else + iisnopen = 0 +end diff --git a/pkg/images/tv/display/iisers.x b/pkg/images/tv/display/iisers.x new file mode 100644 index 00000000..de276a99 --- /dev/null +++ b/pkg/images/tv/display/iisers.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISERS -- Erase IIS frame. + +procedure iisers (chan) + +int chan[ARB] +short erase + +int status, tid +int iisflu(), andi() +include "iis.com" + +begin + call achtiu (andi (ERASE, 0177777B), erase, 1) + + # IMTOOL special - IIS frame bufrer configuration code. + tid = IWRITE+BYPASSIFM+BLOCKXFER + tid = tid + max (0, iis_config - 1) + + call iishdr (tid, 1, FEEDBACK, ADVXONTC, ADVYONXOV, iisflu(chan), + ALLBITPL) + call iisio (erase, SZB_CHAR, status) +end diff --git a/pkg/images/tv/display/iisflu.x b/pkg/images/tv/display/iisflu.x new file mode 100644 index 00000000..3fee9d63 --- /dev/null +++ b/pkg/images/tv/display/iisflu.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISFLU -- IIS frame look up table. + +int procedure iisflu (chan) + +int chan[ARB] +int frame +int iisframe[LEN_IISFRAMES] +data iisframe/IISFRAMES/ + +begin + frame = chan[1] - IIS_CHAN * DEVCODE + if (frame < 1) + return (iisframe[1]) + else if (frame > LEN_IISFRAMES) + return (GRCHAN) + else + return (iisframe[frame]) +end diff --git a/pkg/images/tv/display/iisgop.x b/pkg/images/tv/display/iisgop.x new file mode 100644 index 00000000..c33f21d2 --- /dev/null +++ b/pkg/images/tv/display/iisgop.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# IISGOP -- Open IIS graphics display. + +procedure iisgop (frame, mode, chan) + +int frame, mode, chan[ARB] + +begin + call iisopn (frame + LEN_IISFRAMES, mode, chan) +end diff --git a/pkg/images/tv/display/iishdr.x b/pkg/images/tv/display/iishdr.x new file mode 100644 index 00000000..38ea733d --- /dev/null +++ b/pkg/images/tv/display/iishdr.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" +# IISHDR -- Form IIS header. + +procedure iishdr (id, count, subunit, x, y, z, t) + +int id, count, subunit, x, y, z, t +int i, sum +include "iis.com" + +begin + call achtiu (id, XFERID(hdr), 1) + call achtiu (count, THINGCT(hdr), 1) + call achtiu (subunit, SUBUNIT(hdr), 1) + call achtiu (x, XREG(hdr), 1) + call achtiu (y, YREG(hdr), 1) + call achtiu (z, ZREG(hdr), 1) + call achtiu (t, TREG(hdr), 1) + CHECKSUM(hdr) = 1 + + if (THINGCT(hdr) > 0) + THINGCT(hdr) = -THINGCT(hdr) + sum = 0 + for (i = 1; i <= LEN_IISHDR; i = i + 1) + sum = sum + hdr[i] + call achtiu (-sum, CHECKSUM(hdr), 1) +end diff --git a/pkg/images/tv/display/iisio.x b/pkg/images/tv/display/iisio.x new file mode 100644 index 00000000..ad3902ed --- /dev/null +++ b/pkg/images/tv/display/iisio.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# IISIO -- Synchronous i/o to the IIS. + +procedure iisio (buf, nbytes, status) + +short buf[ARB] +int nbytes +int status + +int xferid +int and() +include "iis.com" + +begin + call iiswt (iischan, status) + xferid = XFERID(hdr) + + if (swap_bytes) + call bswap2 (hdr, 1, hdr, 1, SZB_IISHDR) + call zawrgd (iischan, hdr, SZB_IISHDR, 0) + call iiswt (iischan, status) + + if (and (xferid, IREAD) != 0) { + call zardgd (iischan, buf, nbytes, 0) + call iiswt (iischan, status) + if (swap_bytes && and(xferid,PACKED) == 0) + call bswap2 (buf, 1, buf, 1, nbytes) + } else { + if (swap_bytes && and(xferid,PACKED) == 0) + call bswap2 (buf, 1, buf, 1, nbytes) + call zawrgd (iischan, buf, nbytes, 0) + call iiswt (iischan, status) + } + + if (status <= 0) + status = EOF +end diff --git a/pkg/images/tv/display/iismtc.x b/pkg/images/tv/display/iismtc.x new file mode 100644 index 00000000..2d6eb2cf --- /dev/null +++ b/pkg/images/tv/display/iismtc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISMTC -- Match channel lut to frame2. + +procedure iismtc (chan1, chan2) + +int chan1[ARB], chan2[ARB] +short lut[LEN_LUT] + +int iisflu() + +begin + if (iisflu (chan2) == GRCHAN) + return + call iisrlt (chan1, lut) + call iiswlt (chan2, lut) +end diff --git a/pkg/images/tv/display/iisofm.x b/pkg/images/tv/display/iisofm.x new file mode 100644 index 00000000..24259fd3 --- /dev/null +++ b/pkg/images/tv/display/iisofm.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# These procedures have been modified to limit the maximum output level. + +define NIN 256 # Number of input levels +define NOUT 1024 # Number of output levels + +# IISOFM -- Output color mapping. + +procedure iisofm (map) + +char map[ARB] # type of mapping + +int i +short lutr[LEN_OFM] +short lutg[LEN_OFM] +short lutb[LEN_OFM] + +begin + if (map[1] == 'm') { # MONO + do i = 1, LEN_OFM + lutr[i] = min ((i - 1) * NOUT / NIN, NOUT) + call iiswom (MONO, lutr) + return + } + + call aclrs (lutr, LEN_OFM) + call aclrs (lutg, LEN_OFM) + call aclrs (lutb, LEN_OFM) + + if (map[1] == 'l') { # LINEAR + call iislps (lutb, lutg, lutr) + + } else if (map[1] == '8') { # 8COLOR + do i = 33, 64 { + lutb[i] = NOUT - 1 + lutr[i] = NOUT - 1 + } + do i = 65, 96 + lutb[i] = NOUT - 1 + do i = 97, 128 { + lutb[i] = NOUT - 1 + lutg[i] = NOUT - 1 + } + do i = 129, 160 + lutg[i] = NOUT - 1 + do i = 161, 192 { + lutg[i] = NOUT - 1 + lutr[i] = NOUT - 1 + } + do i = 193, 224 + lutr[i] = NOUT - 1 + do i = 225, 256 { + lutr[i] = NOUT - 1 + lutg[i] = NOUT - 1 + lutb[i] = NOUT - 1 + } + do i = 257, LEN_OFM { + lutr[i] = NOUT - 1 + lutg[i] = NOUT - 1 + lutb[i] = NOUT - 1 + } + + } else if (map[1] == 'r') { # RANDOM + do i = 2, LEN_OFM, 8 { + lutr[i] = NOUT - 1 + lutb[i] = NOUT - 1 + } + do i = 3, LEN_OFM, 8 + lutb[i] = NOUT - 1 + do i = 4, LEN_OFM, 8 { + lutb[i] = NOUT - 1 + lutg[i] = NOUT - 1 + } + do i = 5, LEN_OFM, 8 + lutg[i] = NOUT - 1 + do i = 6, LEN_OFM, 8 { + lutg[i] = NOUT - 1 + lutr[i] = NOUT - 1 + } + do i = 7, LEN_OFM, 8 + lutr[i] = NOUT - 1 + do i = 8, LEN_OFM, 8 { + lutr[i] = NOUT - 1 + lutg[i] = NOUT - 1 + lutb[i] = NOUT - 1 + } + } + + call iiswom (RED, lutr) + call iiswom (GREEN, lutg) + call iiswom (BLUE, lutb) +end + + +# IISWOM -- Write output color look up table. + +procedure iiswom (color, lut) + +int color +short lut[ARB] +int status + +begin + call iishdr (IWRITE+VRETRACE, LEN_OFM, OFM, ADVXONTC, ADVYONXOV, + color, 0) + call iisio (lut, LEN_OFM * SZB_CHAR, status) +end + + +# IISROM -- Read color look up table. + +procedure iisrom (color, lut) + +int color +short lut[ARB] +int status + +begin + call iishdr (IREAD+VRETRACE, LEN_OFM, LUT, ADVXONTC, ADVYONXOV, + color, 0) + call iisio (lut, LEN_OFM * SZB_CHAR, status) +end + + +# Linear Pseudocolor Modelling code. + +define BCEN 64 +define GCEN 128 +define RCEN 196 + +# IISLPS -- Load the RGB luts for linear pseudocolor. + +procedure iislps (lutb, lutg, lutr) + +short lutb[ARB] # blue lut +short lutg[ARB] # green lut +short lutr[ARB] # red lut + +begin + # Set the mappings for the primary color bands. + call iislps_curve (lutb, NIN, BCEN, NOUT - 1, NIN/2) + call iislps_curve (lutg, NIN, GCEN, NOUT - 1, NIN/2) + call iislps_curve (lutr, NIN, RCEN, NOUT - 1, NIN/2) + + # Add one half band of white color at the right. + call iislps_curve (lutb, NIN, NIN, NOUT - 1, NIN/2) + call iislps_curve (lutg, NIN, NIN, NOUT - 1, NIN/2) + call iislps_curve (lutr, NIN, NIN, NOUT - 1, NIN/2) +end + + +# IISLPS_CURVE -- Compute the lookup table for a single color. + +procedure iislps_curve (y, npts, xc, height, width) + +short y[npts] # output curve +int npts # number of points +int xc # x center +int height, width + +int i +real dx, dy, hw + +begin + hw = width / 2.0 + dy = height / hw * 2.0 + + do i = 1, npts { + dx = abs (i - xc) + if (dx > hw) + ; + else if (dx > hw / 2.0) + y[i] = max (int(y[i]), min (height, int((hw - dx) * dy))) + else + y[i] = height + } +end diff --git a/pkg/images/tv/display/iisopn.x b/pkg/images/tv/display/iisopn.x new file mode 100644 index 00000000..a310e168 --- /dev/null +++ b/pkg/images/tv/display/iisopn.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# ---------------------------------------------------------------------- +# MODIFIED VERSION OF IISOPN.X FOR IMTOOL -- DO NOT DELETE. +# Referenced by the Sun/IRAF special file list: see hlib$mkpkg.sf. +# ---------------------------------------------------------------------- + +# IISOPN -- Open IIS display. + +procedure iisopn (devinfo, mode, chan) + +char devinfo[ARB] # device info for zopen (packed) +int mode # access mode +int chan[ARB] # receives IIS descriptor + +int delim +char resource[SZ_FNAME] +char node[SZ_FNAME] +bool first_time +data first_time /true/ +int ki_gnode(), strncmp() +include "iis.com" +include "imd.com" +define quit_ 91 + +begin + if (first_time) { + iisnopen = 0 + iis_version = 0 + first_time = false + } + + # We permit multiple opens but only open the physical device once. + if (iisnopen == 0) { + call zopngd (devinfo, mode, iischan) + + # Initialize imd_gcur. + call strcpy (devinfo, imd_devinfo, SZ_LINE) + imd_mode = mode + imd_magic = -1 + } + + if (iischan != ERR) { + iisnopen = iisnopen + 1 + chan[1] = FRTOCHAN(iisframe) + + # The following code is DEVICE DEPENDENT (horrible kludge, but + # it simplifies things and this is throw away code). + + # Byte pack i/o if the device is on a remote node since the i/o + # bandwidth is the limiting factor; do not bytepack if on local + # node since cpu time is the limiting factor. + + call strupk (devinfo, resource, SZ_FNAME) + packit = (ki_gnode (resource, node, delim) != 0) + if (!packit) + packit = (strncmp (resource[delim+1], "imt", 3) == 0) + + # Enable byte swapping if the device is byte swapped but the + # local host is not (assumes that if there is an IIS it is on + # a byte swapped VAX - this should be done in graphcap instead). + + swap_bytes = (strncmp (resource[delim+1], "iis", 3) == 0 && + BYTE_SWAP2 == NO) + + # Initialize zoom. + call iiszm (1, 0, 0) + + } else + chan[1] = ERR +end diff --git a/pkg/images/tv/display/iispio.x b/pkg/images/tv/display/iispio.x new file mode 100644 index 00000000..81e2512d --- /dev/null +++ b/pkg/images/tv/display/iispio.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# IISPIO -- Asynchronous pixel i/o to the IIS. + +procedure iispio (buf, nx, ny) + +short buf[nx,ny] # Cell array +int nx, ny # length, number of image lines + +pointer iobuf +bool first_time +int xferid, status, nbytes, szline, i +int and() +include "iis.com" +data first_time /true/ + +begin + if (first_time) { + if (packit) + i = IIS_MAXBUFSIZE + else + i = IIS_MAXBUFSIZE * (SZ_SHORT * SZB_CHAR) + call malloc (iobuf, i, TY_SHORT) + first_time = false + } + + # Wait for the last i/o transfer. + call iiswt (iischan, status) + if (status == ERR) + return + + # Disable interrupts while transmitting to or receiving data from + # the display, to avoid loss of synch on the datastream and resulting + # loss of communications with the device. + + call intr_disable() + xferid = XFERID(hdr) + + # Transmit the packet header. + if (swap_bytes) + call bswap2 (hdr, 1, hdr, 1, SZB_IISHDR) + call zawrgd (iischan, hdr, SZB_IISHDR, 0) + call iiswt (iischan, status) + if (status == ERR) { + call intr_enable() + return + } + + # Read or write the data block. + nbytes = ny * iis_xdim + szline = iis_xdim + + if (packit) + szline = szline / (SZ_SHORT * SZB_CHAR) + else + nbytes = nbytes * (SZ_SHORT * SZB_CHAR) + + # Transmit the data byte-packed to increase the i/o bandwith + # when using network i/o. + + if (and (xferid, IREAD) != 0) { + # Read from the IIS. + + call zardgd (iischan, Mems[iobuf], nbytes, 0) + call iiswt (iischan, status) + + # Unpack and line flip the packed data. + if (packit) { + do i = 0, ny-1 + call achtbs (Mems[iobuf+i*szline], buf[1,ny-i], iis_xdim) + } else { + do i = 0, ny-1 + call amovs (Mems[iobuf+i*szline], buf[1,ny-i], szline) + } + + } else { + # Write to the IIS. + + # Bytepack the image lines, doing a line flip in the process. + if (packit) { + do i = 0, ny-1 + call achtsb (buf[1,ny-i], Mems[iobuf+i*szline], iis_xdim) + } else { + do i = 0, ny-1 + call amovs (buf[1,ny-i], Mems[iobuf+i*szline], szline) + } + + call zawrgd (iischan, Mems[iobuf], nbytes, 0) + } + + call intr_enable() +end diff --git a/pkg/images/tv/display/iisrcr.x b/pkg/images/tv/display/iisrcr.x new file mode 100644 index 00000000..53119d06 --- /dev/null +++ b/pkg/images/tv/display/iisrcr.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +define DELAY 30 # milliseconds between cursor reads + + +# IISRCR -- Read cursor from display. Note that the position is 1 indexed. + +procedure iisrcr (status, xcur, ycur) + +int status, xcur, ycur +short cursor[LEN_CURSOR] +include "iis.com" + +begin + call iishdr(IREAD+VRETRACE, LEN_CURSOR, COMMAND+CURSOR, ADVXONTC, 0,0,0) + + call zwmsec (DELAY) + + call iisio (cursor, LEN_CURSOR * SZB_CHAR, status) + if (status <= 0) { + status = EOF + return + } + + status = cursor[1] + xcur = MCXSCALE * mod (cursor[2] + 31, iis_xdim) + ycur = MCYSCALE * mod (cursor[3] + 31, iis_ydim) +end diff --git a/pkg/images/tv/display/iisrd.x b/pkg/images/tv/display/iisrd.x new file mode 100644 index 00000000..3421a71f --- /dev/null +++ b/pkg/images/tv/display/iisrd.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISRD -- Read data from IIS. + +procedure iisrd (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset + +long off1, off2 +int nchars, thing_count, tid, y1, y2, x +int or(), iisflu() +include "iis.com" + +begin + # Convert to chars and clip at the top of the display. + off1 = (offset - 1) / SZB_CHAR + 1 + off2 = min (iis_xdim * iis_ydim, (offset + nbytes - 1) / SZB_CHAR) + 1 + nchars = off2 - off1 + + x = 0 + y1 = (off1-1 ) / iis_xdim + y2 = (off2-1 - iis_xdim) / iis_xdim + y2 = max (y1, y2) + + if (packit) + tid = IREAD+PACKED + else + tid = IREAD + thing_count = nchars + + call iishdr (tid, thing_count, REFRESH, or(x,ADVXONTC), + or(iis_ydim-y2-1, ADVYONXOV), iisflu(chan), ALLBITPL) + + call iispio (buf, iis_xdim, y2 - y1 + 1) +end diff --git a/pkg/images/tv/display/iisrgb.x b/pkg/images/tv/display/iisrgb.x new file mode 100644 index 00000000..9dcc38cd --- /dev/null +++ b/pkg/images/tv/display/iisrgb.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISRGB -- Enable RGB display. + +procedure iisrgb (red_chan, green_chan, blue_chan) + +int red_chan[ARB], green_chan[ARB], blue_chan[ARB] + +int i, frm, status +short split[LEN_SPLIT] +int iisflu() + +begin + frm = iisflu (blue_chan) + do i = 1, 4 + split[i] = frm + + frm = iisflu (green_chan) + do i = 5, 8 + split[i] = frm + + frm = iisflu (red_chan) + do i = 9, 12 + split[i] = frm + + call iishdr (IWRITE+VRETRACE, LEN_SPLIT, COMMAND+LUT, ADVXONTC, 0, 0, 0) + call iisio (split, LEN_SPLIT * SZB_CHAR, status) +end diff --git a/pkg/images/tv/display/iissfr.x b/pkg/images/tv/display/iissfr.x new file mode 100644 index 00000000..f6e92013 --- /dev/null +++ b/pkg/images/tv/display/iissfr.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iis.h" + +# IIS_SETFRAME -- Set the frame number for IISOPN. This is a kludge to pass +# this number to IISOPN via the iis common. + +procedure iis_setframe (frame) + +int frame +include "iis.com" + +begin + iisframe = frame +end diff --git a/pkg/images/tv/display/iisstt.x b/pkg/images/tv/display/iisstt.x new file mode 100644 index 00000000..86474d25 --- /dev/null +++ b/pkg/images/tv/display/iisstt.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# IISSTT -- IIS status. +# [OBSOLETE - NO LONGER USED (see zsttim)] + +procedure iisstt (chan, what, lvalue) + +int chan[ARB], what +long lvalue + +begin + switch (what) { + case FSTT_FILSIZE: + lvalue = IIS_FILSIZE + case FSTT_BLKSIZE: + lvalue = IIS_BLKSIZE + case FSTT_OPTBUFSIZE: + lvalue = IIS_OPTBUFSIZE + case FSTT_MAXBUFSIZE: + lvalue = IIS_MAXBUFSIZE + default: + lvalue = ERR + } +end diff --git a/pkg/images/tv/display/iiswcr.x b/pkg/images/tv/display/iiswcr.x new file mode 100644 index 00000000..3970f230 --- /dev/null +++ b/pkg/images/tv/display/iiswcr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISWCR -- Write cursor to display. Note that the position is 1 indexed. + +procedure iiswcr (status, xcur, ycur) + +int status, xcur, ycur +short cursor[LEN_CURSOR] +include "iis.com" + +begin + call iishdr (IWRITE+VRETRACE, 2, COMMAND+CURSOR, 1+ADVXONTC, 0,0,0) + cursor[2] = mod (xcur / MCXSCALE - 32, iis_xdim) + cursor[3] = mod (ycur / MCYSCALE - 32, iis_ydim) + call iisio (cursor[2], 2 * SZB_CHAR, status) +end diff --git a/pkg/images/tv/display/iiswnd.x b/pkg/images/tv/display/iiswnd.x new file mode 100644 index 00000000..e906cc1f --- /dev/null +++ b/pkg/images/tv/display/iiswnd.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISWND -- Window IIS display frame with the trackball. + +procedure iiswnd3 (chan1, chan2, chan3) + +int chan1[ARB], chan2[ARB], chan3[ARB] + +int i, j +real x, y +short lut[LEN_LUT] +int status, xcur, ycur, lutval +int iisflu(), and() + +begin + if (iisflu(chan1) == GRCHAN) + return + call iisrlt (chan1, lut) + + # Starting point at lut[2] because lut[1] is background + for (i=3; (i < 257) && (lut[i] == lut[2]); i=i+1) + ; + i = i - 1 + + for (j=255; (j > i) && (lut[j] == lut[256]); j=j-1) + ; + j = j + 1 + + if ((i == j) || (lut[i] == lut[j])) { + xcur = 256 + ycur = 384 + } else { + y = real (lut[j] - lut[i]) / (j - i) + xcur = 2 * (i - 1) - (2 * lut[i] - 256) / y + 1 + if (y > 1) + y = 2 - (1 / y) + if (y < -1) + y = -2 - (1 / y) + ycur = 128 * y + 256.5 + } + + xcur = xcur * MCXSCALE + ycur = ycur * MCYSCALE + call iiswcr (status, xcur, ycur) + status = 0 + + while (and (status, PUSH) == 0) { + call iisrcr (status, xcur, ycur) + if (status == EOF) + break + + xcur = xcur / MCXSCALE + ycur = ycur / MCYSCALE + x = xcur / 2 + y = (ycur - 255.5) / 128. + + if (y > 1) + y = 1. / (2 - y) + if (y < - 1) + y = -1. / (2 + y) + do i = 1, 256 { + lutval = y * (i - 1 - x) + 127.5 + lut[i] = max (0, min (255, lutval)) + } + + lut[1] = 0 # Make background black + if ((chan1[1] == chan2[1]) && (chan1[1] == chan3[1])) + call iiswlt (chan1, lut) + else { + call iiswlt (chan1, lut) + call iiswlt (chan2, lut) + call iiswlt (chan3, lut) + } + } +end + + +# IISWLT -- Write monochrome look up table. + +procedure iiswlt (chan, lut) + +int chan[ARB] +short lut[ARB] + +int status +int iisflu() + +begin + if (iisflu (chan) == GRCHAN) + return + call iishdr (IWRITE+VRETRACE, LEN_LUT, LUT, ADVXONTC, 0, chan[2], + iisflu (chan)) + call iisio (lut, LEN_LUT * SZB_CHAR, status) +end + + +# IISRLT -- Read monochrome look up table. + +procedure iisrlt (chan, lut) + +int chan[ARB] +short lut[ARB] + +int status +int iisflu() + +begin + if (iisflu (chan) == GRCHAN) + return + call iishdr (IREAD+VRETRACE, LEN_LUT, LUT, ADVXONTC, 0, 0, + iisflu (chan)) + call iisio (lut, LEN_LUT * SZB_CHAR, status) +end diff --git a/pkg/images/tv/display/iiswr.x b/pkg/images/tv/display/iiswr.x new file mode 100644 index 00000000..68a1a583 --- /dev/null +++ b/pkg/images/tv/display/iiswr.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISWR -- Write pixel data to IIS. Writes are limited to entire display lines. +# The data is line-flipped, causing the first line to be displayed at the bottom +# of the screen. + +procedure iiswr (chan, buf, nbytes, offset) + +int chan[ARB] # io channel +short buf[ARB] # pixels +int nbytes # length of pixel array in bytes +long offset # pixel offset in image display + +long off1, off2 +int nchars, thing_count, tid, y1, y2, x +int or(), iisflu() +include "iis.com" + +begin + # Convert to chars and clip at the top of the display. + off1 = (offset - 1) / SZB_CHAR + 1 + off2 = min (iis_xdim * iis_ydim, (offset + nbytes - 1) / SZB_CHAR) + 1 + nchars = off2 - off1 + + x = 0 + y1 = (off1-1 ) / iis_xdim + y2 = (off2-1 - iis_xdim) / iis_xdim + y2 = max (y1, y2) + +#call eprintf ("iiswr: %d bytes at %d, x=%d, y=[%d:%d]\n") +#call pargi(nbytes); call pargi(offset) +#call pargi(x); call pargi(y1); call pargi(y2) + + if (packit) + tid = IWRITE+BYPASSIFM+BLOCKXFER+BYTE+PACKED + else + tid = IWRITE+BYPASSIFM + thing_count = nchars + + call iishdr (tid, thing_count, REFRESH, or(x,ADVXONTC), + or(iis_ydim-y2-1, ADVYONXOV), iisflu(chan), ALLBITPL) + + call iispio (buf, iis_xdim, y2 - y1 + 1) +end diff --git a/pkg/images/tv/display/iiswt.x b/pkg/images/tv/display/iiswt.x new file mode 100644 index 00000000..ae18ebff --- /dev/null +++ b/pkg/images/tv/display/iiswt.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "zdisplay.h" +include "iis.h" + +# IISWT -- Wait for IIS display. + +procedure iiswt (chan, nbytes) + +int chan[ARB], nbytes +include "iis.com" + +begin + call zawtgd (iischan, nbytes) + if (packit) + nbytes = nbytes * (SZ_SHORT * SZB_CHAR) +end diff --git a/pkg/images/tv/display/iiszm.x b/pkg/images/tv/display/iiszm.x new file mode 100644 index 00000000..d207f47a --- /dev/null +++ b/pkg/images/tv/display/iiszm.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IISZM -- Zoom IIS window. + +procedure iiszm (zfactor, x, y) + +int zfactor, x, y +short zoom[LEN_ZOOM] +int status + +begin + call iishdr (IWRITE+VRETRACE, LEN_ZOOM, ZOOM, ADVXONTC, 0, 0, 0) + zoom[1] = zfactor - 1 + zoom[2] = x / MCXSCALE + zoom[3] = y / MCYSCALE + call iisio (zoom, LEN_ZOOM * SZB_CHAR, status) +end + + +# IISRM -- Roam IIS display. + +procedure iisrm (zfactor) + +int zfactor +int status, xcur, ycur +int and() + +begin + status = 0 + while (status != EOF && and (status, PUSH) == 0) { + call iisrcr (status, xcur, ycur) + call iiszm (zfactor, xcur, ycur) + } +end diff --git a/pkg/images/tv/display/imd.com b/pkg/images/tv/display/imd.com new file mode 100644 index 00000000..9738e89b --- /dev/null +++ b/pkg/images/tv/display/imd.com @@ -0,0 +1,7 @@ +# IMD.COM -- Common for the IMD routines. + +int imd_magic # set to -1 when initialized +int imd_mode # display access mode +char imd_devinfo[SZ_LINE] # device information for zopngd + +common /imdcom/ imd_magic, imd_mode, imd_devinfo diff --git a/pkg/images/tv/display/imdgcur.x b/pkg/images/tv/display/imdgcur.x new file mode 100644 index 00000000..0f8cf658 --- /dev/null +++ b/pkg/images/tv/display/imdgcur.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# IMD_GCUR -- This is functionally equivalent to CLGCUR and should be used in +# place of the latter routine in programs which directly map the display. +# Its function is to close off the display at a low level in order to free +# the display device for access by the CL process for the cursor read. + +int procedure imd_gcur (param, wx, wy, wcs, key, strval, maxch) + +char param[ARB] # parameter to be read [not used] +real wx, wy # cursor coordinates +int wcs # wcs to which coordinates belong +int key # keystroke value of cursor event +char strval[ARB] # string value, if any +int maxch + +int status +bool devopen +int clgcur() +include "iis.com" +include "imd.com" + +begin + devopen = (iisnopen > 0) + if (imd_magic == -1 && devopen) + call zclsgd (iischan, status) + + status = clgcur (param, wx, wy, wcs, key, strval, maxch) + + if (imd_magic == -1 && devopen) + call zopngd (imd_devinfo, imd_mode, iischan) + + return (status) +end diff --git a/pkg/images/tv/display/imdgetwcs.x b/pkg/images/tv/display/imdgetwcs.x new file mode 100644 index 00000000..57f432bc --- /dev/null +++ b/pkg/images/tv/display/imdgetwcs.x @@ -0,0 +1,188 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "zdisplay.h" +include "iis.h" + +# IMD_GETWCS -- Get the saved WCS for the given frame of the given display +# device. (No great attempt at generality here). +# [INTERNAL ROUTINE - RESTRICTED USE]. +# +# Example: +# +# dev$pix - m51 B 600s +# 1. 0. 0. -1. 1. 512. 36. 320.0713 1 +# +# The file format is the image title, followed by a line specifying the +# coordinate transformation matrix (6 numbers: a b c d tx ty) and the +# greyscale transformation (z1 z2 zt). +# +# The procedure returns OK if the WCS for the frame is sucessfully accessed, +# or ERR if the WCS cannot be read. In the latter case the output WCS will +# be the default unitary WCS. + +int procedure imd_getwcs (frame, server, image, sz_image, title, sz_title, + a, b, c, d, tx, ty) + +int frame #I frame (wcs) number of current device +int server #I device is a display server +char image[ARB] #O image name +int sz_image #I max image name length +char title[ARB] #O image title string +int sz_title #I max image title length +real a, d #O x, y scale factors +real b, c #O cross terms (rotations) +real tx, ty #O x, y offsets + +char ch +int fd, chan, status, wcs_status, zt +real z1, z2 +pointer sp, dir, device, fname, wcstext +int envfind(), strncmp(), open(), fscan(), nscan(), stropen(), iisflu() + +include "iis.com" + +begin + call smark (sp) + call salloc (dir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (wcstext, SZ_WCSTEXT, TY_CHAR) + + wcs_status = OK + + # Retrieve the WCS text and open a file descriptor on it. + + if (server == YES) { + # Retrieve the WCS information from a display server. + chan = iisflu(FRTOCHAN(frame)) + + # Cannot use iisio here as the data is byte packed and cannot be + # swapped (while the header still has to be swapped). + + if (iis_version > 0) { + iis_valid = NO + call iishdr (IREAD+PACKED, SZ_WCSTEXT, WCS, 1, 0, chan, 0) + call iisio (Memc[wcstext], SZ_WCSTEXT, status) + if (status > 0) + call strupk (Memc[wcstext], Memc[wcstext], SZ_WCSTEXT) + + iferr (fd = stropen (Memc[wcstext], SZ_WCSTEXT, READ_ONLY)) + fd = NULL + + } else { + call iishdr (IREAD+PACKED, SZ_OLD_WCSTEXT, WCS, 0, 0, chan, 0) + call iisio (Memc[wcstext], SZ_OLD_WCSTEXT, status) + if (status > 0) + call strupk (Memc[wcstext], Memc[wcstext], SZ_OLD_WCSTEXT) + + iferr (fd = stropen (Memc[wcstext], SZ_OLD_WCSTEXT, READ_ONLY)) + fd = NULL + } + + } else { + # Construct the WCS filename, "dir$device_frame.wcs". (Copied from + # the make-WCS code in t_display.x). + + if (envfind ("wcsdir", Memc[dir], SZ_PATHNAME) <= 0) + if (envfind ("WCSDIR", Memc[dir], SZ_PATHNAME) <= 0) + if (envfind ("uparm", Memc[dir], SZ_PATHNAME) <= 0) + call strcpy ("tmp$", Memc[dir], SZ_PATHNAME) + + if (envfind ("stdimage", Memc[device], SZ_FNAME) <= 0) + call strcpy ("display", Memc[device], SZ_FNAME) + + # Get the WCS file filename. + call sprintf (Memc[fname], SZ_PATHNAME, "%s%s_%d.wcs") + call pargstr (Memc[dir]) + if (strncmp (Memc[device], "imt", 3) == 0) + call pargstr ("imtool") + else + call pargstr (Memc[device]) + call pargi (frame) + + if (sz_image > 0) + image[1] = EOS + if (sz_title > 0) + title[1] = EOS + + # Get the saved WCS. + iferr (fd = open (Memc[fname], READ_ONLY, TEXT_FILE)) + fd = NULL + } + + # Decode the WCS from the WCS text. + if (fd != NULL) { + image[1] = EOS + title[1] = EOS + + if (fscan (fd) != EOF) { + # Decode "image - title". + if (sz_image > 0) + call gargwrd (image, sz_image) + if (sz_title > 0) { + call gargwrd (title, sz_title) + repeat { + call gargc (ch) + } until (!IS_WHITE(ch)) + title[1] = ch + call gargstr (title[2], sz_title - 1) + } + + # Decode the WCS information. + if (fscan (fd) != EOF) { + call gargr (a) + call gargr (b) + call gargr (c) + call gargr (d) + call gargr (tx) + call gargr (ty) + call gargr (z1) + call gargr (z2) + call gargi (zt) + if (nscan() == 9) + wcs_status = OK + + if (iis_version > 0) { + if (fscan (fd) != EOF) { + call gargstr (iis_region, SZ_FNAME) + call gargr (iis_sx) + call gargr (iis_sy) + call gargi (iis_snx) + call gargi (iis_sny) + call gargi (iis_dx) + call gargi (iis_dy) + call gargi (iis_dnx) + call gargi (iis_dny) + } + if (nscan() == 9) { + if (fscan (fd) != EOF) + call gargstr (iis_objref, SZ_FNAME) + if (nscan() == 1) + iis_valid = YES + } else + iis_valid = NO + } else { + if (nscan() != 9) { + # Set up the unitary transformation if we + # cannot retrieve the real one. + a = 1.0 + b = 0.0 + c = 0.0 + d = 1.0 + tx = 1.0 + ty = 1.0 + wcs_status = ERR + } + } + } + } + } + + + if (fd != NULL) + call close (fd) + call sfree (sp) + + return (wcs_status) +end diff --git a/pkg/images/tv/display/imdmapfr.x b/pkg/images/tv/display/imdmapfr.x new file mode 100644 index 00000000..745febe2 --- /dev/null +++ b/pkg/images/tv/display/imdmapfr.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "display.h" +include "iis.h" + +# IMD_MAPFRAME -- Open the given frame of the stdimage display device on an +# IMIO image descriptor. + +pointer procedure imd_mapframe (frame, mode, select_frame) + +int frame #I frame to be opened [1:N] +int mode #I access mode +int select_frame #I make frame the display frame + +pointer ds +int chan[MAXCHAN] +char device[SZ_FNAME] + +pointer imdmap() +extern imdopen() +int imstati(), fstati(), envgets() +errchk imdmap, imseti +include "iis.com" + +begin + if (envgets ("stdimage", device, SZ_FNAME) == 0) + call error (1, "variable `stdimage' not defined in environment") + + # Pass frame number into IIS code. + call iis_setframe (frame) + + # Map the frame onto an image descriptor. + ds = imdmap (device, mode, imdopen) + # call imseti (ds, IM_CLOSEFD, YES) + chan[1] = fstati (imstati (ds, IM_PIXFD), F_CHANNEL) + chan[2] = MONO + + # Pick up the frame size. + iis_xdim = IM_LEN(ds,1) + iis_ydim = IM_LEN(ds,2) + iis_config = IM_LEN(ds,3) + + # Optimize for sequential i/o. + call imseti (ds, IM_ADVICE, SEQUENTIAL) + + # Display frame being loaded? + if (select_frame == YES) + call zfrmim (chan) + + return (ds) +end + +# IMD_MAPFRAME1 -- Open the given frame of the stdimage display device on an +# IMIO image descriptor. +# This differs from imd_mapframe only in the addition of the erase option. + +pointer procedure imd_mapframe1 (frame, mode, select_frame, erase) + +int frame #I frame to be opened [1:N] +int mode #I access mode +int select_frame #I make frame the display frame +int erase #I erase frame + +pointer ds +int chan[MAXCHAN] +char device[SZ_FNAME] + +pointer imdmap() +extern imdopen() +int imstati(), fstati(), envgets() +errchk imdmap, imseti +include "iis.com" + +begin + if (envgets ("stdimage", device, SZ_FNAME) == 0) + call error (1, "variable `stdimage' not defined in environment") + + # Pass frame number into IIS code. + call iis_setframe (frame) + + # Map the frame onto an image descriptor. + ds = imdmap (device, mode, imdopen) + # call imseti (ds, IM_CLOSEFD, YES) + chan[1] = fstati (imstati (ds, IM_PIXFD), F_CHANNEL) + chan[2] = MONO + + # Pick up the frame size. + iis_xdim = IM_LEN(ds,1) + iis_ydim = IM_LEN(ds,2) + iis_config = IM_LEN(ds,3) + + # Optimize for sequential i/o. + call imseti (ds, IM_ADVICE, SEQUENTIAL) + + # Display frame being loaded? + if (select_frame == YES) + call zfrmim (chan) + + # Erase frame being loaded? + if (erase == YES) + call zersim (chan) + + return (ds) +end diff --git a/pkg/images/tv/display/imdmapping.x b/pkg/images/tv/display/imdmapping.x new file mode 100644 index 00000000..049bef1b --- /dev/null +++ b/pkg/images/tv/display/imdmapping.x @@ -0,0 +1,194 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "zdisplay.h" + +.help imd_setmapping, imd_getmapping, imd_query_map +.nf ____________________________________________________________________________ + + Interface routines for setting and getting display server mappings. + + imd_setmapping (region, sx,sy,snx,sny, dx,dy,dnx,dny, objref) + status = imd_getmapping (region, sx,sy,snx,sny, dx,dy,dnx,dny, objref) + status = imd_query_map (wcs, region, sx,sy,snx,sny, dx,dy,dnx,dny, objref) + +The imd_setmapping() procedure should be called prior to an imd_putwcs() +if the mapping information is to be sent with the next WCS write. The +imd_getmapping() function returns a non-zero status if the last WCS query +returned valid mapping information during the read. Both routines depend +upon a previous call to imd_wcsver() (imdmapping.x) to initialize the common +to query the server for this new capability. The imd_query_map() function +returns a non-zero status if a valid mapping is available for the given WCS +number (e.g. the wcs number returned by a cursor read can be entered and +information such as the image name can be returned for the associated mapping). + +.endhelp _______________________________________________________________________ + + +# IMD_SETMAPPING -- Set the mapping information to be sent with the next +# SETWCS command. + +procedure imd_setmapping (reg, sx, sy, snx, sny, dx, dy, dnx, dny, objref) + +char reg[SZ_FNAME] #i region name +real sx, sy #i source raster +int snx, sny +int dx, dy #i destination raster +int dnx, dny +char objref[SZ_FNAME] #i object reference + +bool streq() + +include "iis.com" + +begin + call strcpy (reg, iis_region, SZ_FNAME) + iis_sx = sx + iis_sy = sy + iis_snx = snx + iis_sny = sny + iis_dx = dx + iis_dy = dy + iis_dnx = dnx + iis_dny = dny + + if (streq (objref, "dev$pix")) + call fpathname ("dev$pix.imh", iis_objref, SZ_FNAME) + else + call strcpy (objref, iis_objref, SZ_FNAME) + + iis_valid = YES +end + + +# IMD_GETMAPPING -- Get the mapping information returned with the last +# GETWCS command. + +int procedure imd_getmapping (reg, sx, sy, snx, sny, dx, dy, dnx, dny, objref) + +char reg[SZ_FNAME] #o region name +real sx, sy #o source raster +int snx, sny +int dx, dy #o destination raster +int dnx, dny +char objref[SZ_FNAME] #o object reference + +include "iis.com" + +begin + if (iis_valid == YES) { + call strcpy (iis_region, reg, SZ_FNAME) + sx = iis_sx + sy = iis_sy + snx = iis_snx + sny = iis_sny + dx = iis_dx + dy = iis_dy + dnx = iis_dnx + dny = iis_dny + call strcpy (iis_objref, objref, SZ_FNAME) + } + return (iis_valid) +end + + +# IMD_QUERY_MAP -- Return the mapping information in the server for the +# specified WCS number. + +int procedure imd_query_map (wcs, reg, sx,sy,snx,sny, dx,dy,dnx,dny, objref) + +int wcs #i WCS number of request +char reg[SZ_FNAME] #o region name +real sx, sy #o source raster +int snx, sny +int dx, dy #o destination raster +int dnx, dny +char objref[SZ_FNAME] #o object reference + +pointer sp, wcstext, ip, ds +int fd, frame, chan, status, wcs_status, nl + +int fscan(), stropen(), iisflu() +pointer imd_mapframe1() + +include "iis.com" +define done_ 91 + +begin + call smark (sp) + call salloc (wcstext, SZ_WCSTEXT, TY_CHAR) + call aclrc (Memc[wcstext], SZ_WCSTEXT) + + wcs_status = ERR + iis_valid = NO + frame = wcs / 100 + ds = NULL + + if (iis_version > 0) { + + # If the channel isn't currently open, map the frame temporarily + # so we get a valid read. + if (iisnopen == 0) + ds = imd_mapframe1 (frame, READ_ONLY, NO, NO) + + # Retrieve the WCS information from a display server. + chan = iisflu(FRTOCHAN(frame)) + + # Query the server using the X register to indicate this is + # a "new form" of the WCS query, and pass the requested WCS in + # the T register (which is normally zero). + + call iishdr (IREAD+PACKED, SZ_WCSTEXT, WCS, 1, 0, chan, wcs) + call iisio (Memc[wcstext], SZ_WCSTEXT, status) + if (status > 0) + call strupk (Memc[wcstext], Memc[wcstext], SZ_WCSTEXT) + else + goto done_ + + + # Skip the wcs part of the string, we only want the mapping. + nl = 0 + for (ip=wcstext ; Memc[ip] != NULL; ip=ip+1) { + if (Memc[ip] == '\n') + nl = nl + 1 + if (nl == 2) + break + } + ip = ip + 1 + + # Open the string for reading. + iferr (fd = stropen (Memc[ip], SZ_WCSTEXT, READ_ONLY)) + fd = NULL + + # Decode the Mapping from the WCS text. + if (fd != NULL) { + if (fscan (fd) != EOF) { + call gargwrd (reg, SZ_FNAME) + call gargr (sx) + call gargr (sy) + call gargi (snx) + call gargi (sny) + call gargi (dx) + call gargi (dy) + call gargi (dnx) + call gargi (dny) + + if (fscan (fd) != EOF) { + call gargstr (objref, SZ_FNAME) + wcs_status = OK + iis_valid = YES + } + } + } + + # Close any temporary connection to the server. + if (ds != NULL) + call imunmap (ds) + } + +done_ if (fd != NULL) + call close (fd) + call sfree (sp) + return (wcs_status) +end diff --git a/pkg/images/tv/display/imdopen.x b/pkg/images/tv/display/imdopen.x new file mode 100644 index 00000000..85950270 --- /dev/null +++ b/pkg/images/tv/display/imdopen.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMDOPEN -- Open the image display device as a binary file. + +int procedure imdopen (fname, access_mode) + +char fname[ARB] +int access_mode, fopnbf() +extern zopnim(), zclsim(), zardim(), zawrim(), zawtim(), zsttim() + +begin + return (fopnbf (fname, access_mode, + zopnim, zardim, zawrim, zawtim, zsttim, zclsim)) +end diff --git a/pkg/images/tv/display/imdputwcs.x b/pkg/images/tv/display/imdputwcs.x new file mode 100644 index 00000000..a7b55c8c --- /dev/null +++ b/pkg/images/tv/display/imdputwcs.x @@ -0,0 +1,139 @@ +include +include +include +include +include "display.h" +include "iis.h" + + +# IMD_PUTWCS -- Write WCS. + +procedure imd_putwcs (ds, frame, str1, str2, a, b, c, d, tx, ty, z1, z2, ztr) +pointer ds #I IMIO descriptor for image display. +int frame #I Frame number for which WCS is to be set. +char str1[ARB] #I First title string (image name). +char str2[ARB] #I Second title string (image title). +real a, d #I x, y scale factors. +real b, c #I cross terms (rotations). +real tx, ty #I x, y offsets. +real z1, z2 #I min and maximum grey scale values. +int ztr #I greyscale transformation code. + +pointer sp, old_wcs, mapping, wcstext, dir, fname, ftemp, device +int wcsfile, server, chan[MAXCHAN] +int fstati(), imstati(), envfind(), open(), strncmp() + +include "iis.com" + +begin + call smark (sp) + call salloc (old_wcs, SZ_WCSTEXT, TY_CHAR) + call salloc (mapping, SZ_WCSTEXT, TY_CHAR) + call salloc (wcstext, SZ_WCSTEXT, TY_CHAR) + + # Format the WCS text. + call sprintf (Memc[old_wcs], SZ_WCSTEXT, + "%s - %s\n%g %g %g %g %g %g %g %g %d\n") + call pargstr (str1) + call pargstr (str2) + call pargr (a) + call pargr (b) + call pargr (c) + call pargr (d) + call pargr (tx) + call pargr (ty) + call pargr (z1) + call pargr (z2) + call pargi (ztr) + + # Add the mapping information if it's valid and we have a capable + # server. + if (iis_version > 0 && iis_valid == YES) { + call sprintf (Memc[mapping], SZ_WCSTEXT, + "%s %g %g %d %d %d %d %d %d\n%s\n") + call pargstr (iis_region) + call pargr (iis_sx) + call pargr (iis_sy) + call pargi (iis_snx) + call pargi (iis_sny) + call pargi (iis_dx) + call pargi (iis_dy) + call pargi (iis_dnx) + call pargi (iis_dny) + call pargstr (iis_objref) + + call sprintf (Memc[wcstext], SZ_WCSTEXT, "%s%s") + call pargstr (Memc[old_wcs]) + call pargstr (Memc[mapping]) + } else + call strcpy (Memc[old_wcs], Memc[wcstext], SZ_OLD_WCSTEXT) + + + # If we are writing to a display server (device has the logical + # cursor capability), output the WCS text via the datastream, + # else use a text file. The datastream set-WCS is also used to + # pass the frame buffer configuration to server devices. + + server = IM_LEN (ds, 4) + + if (server == YES) { + chan[1] = fstati (imstati (ds, IM_PIXFD), F_CHANNEL) + chan[2] = MONO + call imd_setwcs (chan, Memc[wcstext]) + + # Invalidate the mapping once it's been sent. + iis_valid = NO + + } else { + # Construct the WCS filename, "dir$device_frame.wcs". + call salloc (dir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (ftemp, SZ_PATHNAME, TY_CHAR) + call salloc (device, SZ_FNAME, TY_CHAR) + + if (envfind ("wcsdir", Memc[dir], SZ_PATHNAME) <= 0) + if (envfind ("WCSDIR", Memc[dir], SZ_PATHNAME) <= 0) + if (envfind ("uparm", Memc[dir], SZ_PATHNAME) <= 0) + call strcpy ("tmp$", Memc[dir], SZ_PATHNAME) + + if (envfind ("stdimage", Memc[device], SZ_FNAME) <= 0) + call strcpy ("display", Memc[device], SZ_FNAME) + + # Get a temporary file in the WCS directory. + call sprintf (Memc[ftemp], SZ_PATHNAME, "%swcs") + call pargstr (Memc[dir]) + call mktemp (Memc[ftemp], Memc[ftemp], SZ_PATHNAME) + + # Make the final WCS file filename. + call sprintf (Memc[fname], SZ_PATHNAME, "%s%s_%d.wcs") + call pargstr (Memc[dir]) + if (strncmp (Memc[device], "imt", 3) == 0) + call pargstr ("imtool") + else + call pargstr (Memc[device]) + call pargi (frame) + + # Update the WCS file. + iferr (wcsfile = open (Memc[ftemp], TEMP_FILE, TEXT_FILE)) + call erract (EA_WARN) + else { + # Now delete the old file, if any, and write the new one. + # To avoid process race conditions, create the new file as an + # atomic operation, first writing a new file and then renaming + # it to create the WCS file. + + iferr (call delete (Memc[fname])) + ; + + # Output the file version. + call putline (wcsfile, Memc[wcstext]) + call close (wcsfile) + + # Install the new file. + iferr (call rename (Memc[ftemp], Memc[fname])) + call erract (EA_WARN) + } + } + + call sfree (sp) +end diff --git a/pkg/images/tv/display/imdrcur.x b/pkg/images/tv/display/imdrcur.x new file mode 100644 index 00000000..34148b5b --- /dev/null +++ b/pkg/images/tv/display/imdrcur.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMDRCUR -- Read the logical image cursor of the named image display device. +# opened with IMDOPEN). This is a high level cursor read, returning image +# pixel coordinates and relying upon the display server to use the keyboard or +# mouse to terminate the cursor read. Nonblocking reads and frame buffer +# coordinates are available as options. The user is expected to select the +# frame for which coordintes are to be returned; the frame number is returned +# in the encoded WCS. The cursor key is returned as the function value. + +int procedure imdrcur (device, x, y, wcs, key, strval, maxch, in_wcs, pause) + +char device[ARB] #I image display device +real x, y #O cursor coords given WCS +int wcs #O WCS of coordinates (frame*100+in_wcs) +int key #O keystroke which triggered cursor read +char strval[maxch] #O optional string value +int maxch #I max chars out +int in_wcs #I desired wcs: 0=frame, 1=image +int pause #I blocking cursor read? (YES|NO) + +char ch +int fd, op +pointer sp, curval, devname, tty, dd, ip + +bool streq() +pointer ttygdes() +int imdopen(), ttygets(), envgets(), nscan(), stg_getline() + +string eof "EOF\n" +string stdimage "stdimage" +errchk ttygdes, imdopen, imdrcuro + +begin + call smark (sp) + call salloc (devname, SZ_FNAME, TY_CHAR) + call salloc (curval, SZ_LINE, TY_CHAR) + call salloc (dd, SZ_LINE, TY_CHAR) + + # Get the logical device name. + if (streq (device, stdimage)) { + if (envgets (stdimage, Memc[devname], SZ_FNAME) <= 0) + call strcpy (device, Memc[devname], SZ_FNAME) + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + # Get the DD kernel driver string for the device. + tty = ttygdes (Memc[devname]) + if (ttygets (tty, "DD", Memc[dd], SZ_LINE) <= 0) + call strcpy (Memc[devname], Memc[dd], SZ_FNAME) + + # Open the device and read the logical image cursor. + fd = imdopen (Memc[dd], READ_WRITE) + call imdrcuro (tty, Memc[curval], SZ_LINE, in_wcs, pause) + + # Decode the formatted cursor value string. + if (streq (Memc[curval], eof)) { + key = EOF + } else { + call sscan (Memc[curval]) + call gargr (x) + call gargr (y) + call gargi (wcs) + call gargc (ch) + call gargstr (Memc[curval], SZ_LINE) + + key = ch + if (nscan() < 4) + key = ERR + + ip = curval + if (nscan() < 5) + Memc[curval] = EOS + else { + while (IS_WHITE(Memc[ip]) || Memc[ip] == '\n') + ip = ip + 1 + } + } + + # In this implementation, string input for colon commands is via the + # terminal to avoid the complexities of character i/o to the display. + # Note that the lower level code can return the string value if it + # chooses to (must be a nonnull string). + + strval[1] = EOS + if (key == ':') { + # String value not already set by imdrcuro? + if (Memc[ip] == EOS) { + call stg_putline (STDOUT, ":") + if (stg_getline (STDIN, Memc[curval]) == EOF) + Memc[curval] = EOS + else + for (ip=curval; IS_WHITE (Memc[ip]); ip=ip+1) + ; + } + + # Copy to the output string argument. + op = 1 + while (Memc[ip] != '\n' && Memc[ip] != EOS) { + strval[op] = Memc[ip] + op = min (op + 1, maxch) + ip = ip + 1 + } + strval[op] = EOS + } + + # Map ctrl/d and ctrl/z onto EOF. + if (key == '\004' || key == '\032') + key = EOF + + call close (fd) + call ttycdes (tty) + + return (key) +end diff --git a/pkg/images/tv/display/imdrcuro.x b/pkg/images/tv/display/imdrcuro.x new file mode 100644 index 00000000..2296fd03 --- /dev/null +++ b/pkg/images/tv/display/imdrcuro.x @@ -0,0 +1,206 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "zdisplay.h" +include "iis.h" + +define NEXT_FRAME '\006' +define PREV_FRAME '\022' +define TOGGLE_MARK '\015' + +# IMDRCURO -- Read the logical image cursor from an already opened image +# display device (opened with IMDOPEN). This is a high level cursor read, +# returning image pixel coordinates and relying upon the display server to use +# the keyboard or mouse to terminate the cursor read. Nonblocking reads and +# frame buffer coordinates are available as options. The cursor value is +# returned as an ascii string encoded as follows: +# +# wx wy wcs key [strval] +# +# where WX,WY are the cursor coordinates in the coordinate system defined by +# WCS (= framenumber*100 + wcs, wcs=0 for frame buffer coordinates, wcs=1 for +# image pixel coordinates, the default), KEY is the keystroke used to terminate +# the cursor read, and STRVAL is the string value of the cursor, if key=':' +# (a colon command). Nonprintable keys are returned as octal escapes. + +procedure imdrcuro (tty, outstr, maxch, wcs, pause) + +pointer tty #I graphcap descriptor for device +char outstr[maxch] #O formatted output cursor value +int maxch #I max chars out +int wcs #I desired wcs: 0=framecoords, 1=imagecoords +int pause #I blocking cursor read? (YES|NO) + +short cursor[3] +char key, str[1] +short split[LEN_SPLIT] +pointer sp, strval, imcurval +real a, b, c, d, tx, ty, wx, wy +int status, frame, tid, z, n, keystat, sx, sy, ip, chan, i + +bool mark_cursor +data mark_cursor /false/ + +bool ttygetb() +int rdukey(), ttygeti(), cctoc(), iisflu(), imd_getwcs() +define again_ 91 +include "iis.com" + +begin + call smark (sp) + call salloc (strval, SZ_LINE, TY_CHAR) + call salloc (imcurval, SZB_IMCURVAL, TY_CHAR) + + if (ttygetb (tty, "LC")) { + # Logical image cursor read; the display server supports the + # logical image cursor read as an atomic operation, via the + # logical subunit IMCURSOR (an IRAF special extension to the + # regular IIS datastream protocol). + + if (pause == NO) + tid = IREAD + SAMPLE + else + tid = IREAD + + call iishdr (tid, SZB_IMCURVAL, COMMAND+IMCURSOR, 0,0, wcs, 0) + + call iisio (Memc[imcurval], SZB_IMCURVAL, status) + if (status <= 0) + call strcpy ("EOF\n", outstr, maxch) + else + call strupk (Memc[imcurval], outstr, maxch) + + } else { + # IIS compatible cursor read. Implement the logical cursor read + # using only the primitive IIS cursor functions and the terminal + # driver, accessing the WCS file directly to get the coordinate + # transformation from IIS device coords to image pixel coords. + + # Pick up the frame size and configuration number. + iis_xdim = ttygeti (tty, "xr") + iis_ydim = ttygeti (tty, "yr") + iis_config = ttygeti (tty, "cn") +again_ + if (pause == YES) { + # Enable cursor blink to indicate cursor read in progress. + call iishdr (IWRITE+VRETRACE,1,COMMAND+CURSOR, ADVXONTC, 0,0,0) + cursor[1] = 57B + call iisio (cursor, SZ_SHORT * SZB_CHAR, status) + + # Wait for the user to type a key on the keyboard. The value + # is returned as a newline delimited string. + + keystat = rdukey (Memc[strval], SZ_LINE) + + } else { + Memc[strval] = '\n' + Memc[strval+1] = EOS + keystat = 1 + } + + # Sample the cursor position. + call iisrcr (status, sx, sy) + sx = sx / MCXSCALE + sy = sy / MCYSCALE + + # Determine which frame was being displayed. + call iishdr (IREAD, LEN_SPLIT, COMMAND+LUT, ADVXONTC, 0,0,0) + call iisio (split, LEN_SPLIT * SZB_CHAR, status) + + z = split[1] + if (z == 0) + z = 1 + for (n=1; and(z,1) == 0; z = z / 2) + n = n + 1 + frame = max(1, min(4, n)) + chan = FRTOCHAN(frame) + + if (pause == YES) { + # Turn off cursor blink. + call iishdr (IWRITE+VRETRACE,1,COMMAND+CURSOR, ADVXONTC, 0,0,0) + cursor[1] = 47B + call iisio (cursor, SZ_SHORT * SZB_CHAR, status) + } + + # Decode the trigger keystroke. + ip = 1 + if (cctoc (Memc[strval], ip, key) <= 0) + key = 0 + + # Check for the builtin pseudo "cursor mode" commands. + switch (key) { + case NEXT_FRAME: + # Display the next frame in sequence. + frame = frame + 1 + if (frame > 4) + frame = 1 + chan = IIS_CHAN * DEVCODE + frame + call iisrgb (chan, chan, chan) + goto again_ + case PREV_FRAME: + # Display the previous frame. + frame = frame - 1 + if (frame <= 0) + frame = 1 + chan = IIS_CHAN * DEVCODE + frame + call iisrgb (chan, chan, chan) + goto again_ + case TOGGLE_MARK: + # Toggle the mark cursor enable. + mark_cursor = !mark_cursor + goto again_ + } + + # Mark the cursor position by editing the frame buffer. + if (mark_cursor && keystat > 1 && key != '\004' && key != '\032') { + do i = 1, 3 + cursor[i] = 1 + call achtsb (cursor, cursor, 3) + + call iishdr (IWRITE+BYPASSIFM+PACKED+VRETRACE, 3, REFRESH, + or(sx-1,ADVXONTC), or(sy-1,ADVYONXOV), + iisflu(chan), ALLBITPL) + call iisio (cursor, 3, status) + + call iishdr (IWRITE+BYPASSIFM+PACKED+VRETRACE, 3, REFRESH, + or(sx-1,ADVXONTC), or(sy,ADVYONXOV), + iisflu(chan), ALLBITPL) + call iisio (cursor, 3, status) + + call iishdr (IWRITE+BYPASSIFM+PACKED+VRETRACE, 3, REFRESH, + or(sx-1,ADVXONTC), or(sy+1,ADVYONXOV), + iisflu(chan), ALLBITPL) + call iisio (cursor, 3, status) + } + + # Perform the transformation to image pixel coordinates. + if (wcs != 0) { + if (imd_getwcs (frame,NO, str,0,str,0, a,b,c,d,tx,ty) == ERR) { + call eprintf ("Warning: cannot retrieve WCS for frame %d\n") + call pargi (frame) + } + if (abs(a) > .001) + wx = sx * a + tx + if (abs(d) > .001) + wy = sy * d + ty + } else { + wx = sx + wy = sy + } + + # Format the output cursor value string. + if (keystat == EOF) + call strcpy ("EOF\n", outstr, maxch) + else { + call sprintf (outstr, maxch, "%.6g %.6g %d %s") + call pargr (wx) + call pargr (wy) + call pargi (frame * 100 + wcs) + call pargstr (Memc[strval]) + } + } + + call sfree (sp) +end diff --git a/pkg/images/tv/display/imdsetwcs.x b/pkg/images/tv/display/imdsetwcs.x new file mode 100644 index 00000000..98e8afdc --- /dev/null +++ b/pkg/images/tv/display/imdsetwcs.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# IMD_SETWCS -- Pass the WCS for the indicated reference frame to a display +# server. The frame buffer configuration is also passed. + +procedure imd_setwcs (chan, wcstext) + +int chan #I display channel code (frame) +char wcstext[ARB] #I wcs text + +pointer sp, pkwcs +int status, count +int strlen(), iisflu() +include "iis.com" + +begin + count = strlen (wcstext) + 1 + + call smark (sp) + call salloc (pkwcs, count, TY_CHAR) + call strpak (wcstext, Memc[pkwcs], count) + + call iishdr (IWRITE+PACKED, count, WCS, iis_version, 0, iisflu(chan), + max(0,iis_config-1)) + call iisio (Memc[pkwcs], count, status) + + call sfree (sp) +end diff --git a/pkg/images/tv/display/imdwcs.x b/pkg/images/tv/display/imdwcs.x new file mode 100644 index 00000000..66d6b4b5 --- /dev/null +++ b/pkg/images/tv/display/imdwcs.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help imdwcs +.nf ------------------------------------------------------------------------- +IMDWCS -- Simple interim WCS package for the display interface. This is a +restricted use interface which will be obsoleted by a future interface. + + iw = iw_open (ds, frame, imname, sz_imname, status) + iw_fb2im (iw, fb_x,fb_y, im_x,im_y) + iw_im2fb (iw, im_x,im_y, fb_x,fb_y) + iw_close (iw) + + +This facility uses the WCSDIR file mechanism to retrieve the WCS information +for a display frame. The display name is given by the current value of the +'stdimage' environment variable. Although the WCSDIR info supports a full +2D rotation matrix we recognize only scale and shift terms here. + +NOTE -- The frame buffer coordinates used here are defined in the coordinate +system of the DISPLAY program, IMD_MAPFRAME, etc., i.e., the origin is at the +lower left corner of the frame, and the system is one-indexed. The WCS file, +on the other hand, stores device frame buffer coordinates, which are zero +indexed with the origin at the upper left. +.endhelp -------------------------------------------------------------------- + +define LEN_IWDES 6 + +define IW_A Memr[P2R($1)] # x scale +define IW_B Memr[P2R($1+1)] # cross term (not used) +define IW_C Memr[P2R($1+2)] # cross term (not used) +define IW_D Memr[P2R($1+3)] # y scale +define IW_TX Memr[P2R($1+4)] # x shift +define IW_TY Memr[P2R($1+5)] # y shift + + +# IW_OPEN -- Retrieve the WCS information for the given frame of the stdimage +# display device. If the WCS for the frame cannot be accessed for any reason +# a unitary transformation is returned and wcs_status is set to ERR. Note that +# this is not a hard error, i.e., a valid descriptor is still returned. + +pointer procedure iw_open (ds, frame, imname, sz_imname, wcs_status) + +pointer ds #I display image descriptor +int frame #I frame number for which WCS is desired +char imname[ARB] #O receives name of image loaded into frame (if any) +int sz_imname #I max chars out to imname[]. +int wcs_status #O ERR if WCS cannot be accessed, OK otherwise + +pointer iw +int server +char junk[1] +int imd_getwcs() +errchk calloc + +begin + call calloc (iw, LEN_IWDES, TY_STRUCT) + + # Get the WCS. + server = IM_LEN(ds,4) + wcs_status = imd_getwcs (frame, server, imname, sz_imname, junk,0, + IW_A(iw), IW_B(iw), IW_C(iw), IW_D(iw), IW_TX(iw), IW_TY(iw)) + + # Avoid divide by zero problems if invalid WCS. + if (abs(IW_A(iw)) < .0001 || abs(IW_D(iw)) < .0001) { + + IW_A(iw) = 1.0; IW_D(iw) = 1.0 + IW_TX(iw) = 0.0; IW_TY(iw) = 0.0 + wcs_status = ERR + + } else { + # Convert hardware FB to display FB coordinates. + IW_TY(iw) = IW_TY(iw) + (IW_D(iw) * (IM_LEN(ds,2)-1)) + IW_D(iw) = -IW_D(iw) + } + + return (iw) +end + + +# IW_FB2IM -- Convert frame buffer coordinates to image pixel coordinates. + +procedure iw_fb2im (iw, fb_x,fb_y, im_x,im_y) + +pointer iw #I imd wcs descriptor +real fb_x,fb_y #I frame buffer X,Y coordinates +real im_x,im_y #O image pixel X,Y coordinates + +begin + im_x = (fb_x - 1) * IW_A(iw) + IW_TX(iw) + im_y = (fb_y - 1) * IW_D(iw) + IW_TY(iw) +end + + +# IW_IM2FB -- Convert image pixel coordinates to frame buffer coordinates. + +procedure iw_im2fb (iw, im_x,im_y, fb_x,fb_y) + +pointer iw #I imd wcs descriptor +real im_x,im_y #I image pixel X,Y coordinates +real fb_x,fb_y #O frame buffer X,Y coordinates + +begin + fb_x = (im_x - IW_TX(iw)) / IW_A(iw) + 1 + fb_y = (im_y - IW_TY(iw)) / IW_D(iw) + 1 +end + + +# IW_CLOSE -- Close the IW descriptor. + +procedure iw_close (iw) + +pointer iw #I imd wcs descriptor + +begin + call mfree (iw, TY_STRUCT) +end diff --git a/pkg/images/tv/display/imdwcsver.x b/pkg/images/tv/display/imdwcsver.x new file mode 100644 index 00000000..f8fd9a08 --- /dev/null +++ b/pkg/images/tv/display/imdwcsver.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iis.h" +include "zdisplay.h" + +# IMD_WCSVER -- Query the server for the WCS version supported. A zero +# will be returned for the "old" wcs format used, otherwise the server +# will return a version identifier. + +int procedure imd_wcsver () + +pointer ds +int chan, status, frame, ip +char wcstext[SZ_OLD_WCSTEXT] + +int strncmp(), ctoi(), iisflu() +pointer imd_mapframe1() +bool envgetb() + +include "iis.com" + +begin + iis_valid = NO # initialize + + # Check the environment for a flag to disable the new WCS info. + if (envgetb ("disable_wcs_maps")) { + iis_version = 0 + return (iis_version) + } + + # Open a temporary connection to the server if needed. + ds = NULL + if (iisnopen == 0) + ds = imd_mapframe1 (1, READ_ONLY, NO, NO) + + # Send a WCS query with the X and Y register set. This tells a + # knowledgeable server to reply with a WCS version string, + # otherwise it is a no-op and we get the normal WCS response + # indicating the old format. + + frame = 1 + chan = iisflu (FRTOCHAN(frame)) + call aclrc (wcstext, SZ_OLD_WCSTEXT) + call iishdr (IREAD+PACKED, SZ_OLD_WCSTEXT, WCS, 1, 1, chan, 0) + call iisio (wcstext, SZ_OLD_WCSTEXT, status) + if (status > 0) + call strupk (wcstext, wcstext, SZ_OLD_WCSTEXT) + else { + iis_version = 0 + call imunmap (ds) + return (iis_version) + } + + # Decode the version from the WCS text. + if (strncmp (wcstext, "version=", 8) == 0) { + ip = 9 + status = ctoi (wcstext, ip, iis_version) + } else + iis_version = 0 + + + if (ds != NULL) + call imunmap (ds) + return (iis_version) +end diff --git a/pkg/images/tv/display/maskcolor.x b/pkg/images/tv/display/maskcolor.x new file mode 100644 index 00000000..aa78d77b --- /dev/null +++ b/pkg/images/tv/display/maskcolor.x @@ -0,0 +1,478 @@ +include +include +include "ace.h" + +define COLORS "|black|white|red|green|blue|yellow|cyan|magenta|transparent|" +define DEFCOLOR 203 + + +# MASKCOLOR_MAP -- Create the mask colormap object. + +pointer procedure maskcolor_map (colorstring) + +char colorstring #I Color specification string +pointer colors #O Mask colormap object + +int i, j, ip, ncolors, token, lasttoken, maskval1, maskval2, color, offset +int strdic(), ctoi(), nowhite() +pointer sp, str, op + +int coltrans[9] +data coltrans/202,203,204,205,206,207,208,209,-1/ + +define err_ 10 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # If the colorstring is an expression just save the string + # and set the number of colors to 0. + i = nowhite (colorstring, Memc[str], SZ_LINE) + if (Memc[str] == '(') { + call malloc (colors, SZ_LINE, TY_INT) + call malloc (op, LEN_OPERAND, TY_STRUCT) + Memi[colors] = 0 + Memi[colors+1] = op + call strcpy (colorstring, Memc[P2C(colors+2)], SZ_LINE) + O_TYPE(op) = TY_INT + O_VALP(op) = NULL + O_FLAGS(op) = O_FREEOP + # Check expression here. + return (colors) + } + + # Allocate memory for the colormap object. + call malloc (colors, 4*10, TY_INT) + + # Initialize + ncolors = 1 + maskval1 = INDEFI + maskval2 = INDEFI + color = DEFCOLOR + offset = NO + + Memi[colors] = ncolors + Memi[colors+2] = color + Memi[colors+3] = offset + + # Parse the color specification. + token = 0 + call sscan (colorstring) + repeat { + lasttoken = token + call gargtok (token, Memc[str], SZ_LINE) + switch (token) { + case TOK_IDENTIFIER: + call strlwr (Memc[str]) + i = strdic (Memc[str], Memc[str], SZ_LINE, COLORS) + if (i == 0) + goto err_ + color = coltrans[i] + case TOK_NUMBER: + if (lasttoken == TOK_NUMBER) { + if (Memc[str] != '-') + goto err_ + ip = 2 + if (ctoi (Memc[str], ip, maskval2) == 0) + goto err_ + } else { + if (Memc[str] == '+') { + offset = YES + ip = 2 + } else if (Memc[str] == '-') { + offset = YES + ip = 1 + } else + ip = 1 + if (ctoi (Memc[str], ip, color) == 0) + goto err_ + if (lasttoken != TOK_OPERATOR) + maskval2 = color + } + case TOK_OPERATOR: + if (Memc[str] != '=' || lasttoken != TOK_NUMBER) + goto err_ + maskval1 = min (color, maskval2) + maskval2 = max (color, maskval2) + + if (Memc[str+1] == '+') { + call gargtok (token, Memc[str+2], SZ_LINE) + offset = YES + ip = 3 + if (ctoi (Memc[str], ip, color) == 0) + goto err_ + } else if (Memc[str+1] == '-') { + call gargtok (token, Memc[str+2], SZ_LINE) + offset = YES + ip = 2 + if (ctoi (Memc[str], ip, color) == 0) + goto err_ + } + case TOK_PUNCTUATION, TOK_EOS: + if (Memc[str] != ',' && Memc[str] != EOS) + goto err_ + if (!IS_INDEFI(maskval1)) { + do i = 2, ncolors { + j = 4 * i - 4 + if (Memi[colors+j] == maskval1 && + Memi[colors+j+1] == maskval2) + break + } + if (i > ncolors) { + if (mod (ncolors, 10) == 0) + call realloc (colors, 4*(ncolors+10), TY_INT) + ncolors = ncolors + 1 + } + j = 4 * i - 4 + Memi[colors+j] = maskval1 + Memi[colors+j+1] = maskval2 + Memi[colors+j+2] = color + Memi[colors+j+3] = offset + } else { + Memi[colors+2] = color + Memi[colors+3] = offset + } + if (token == TOK_EOS) + break + maskval1 = INDEFI + maskval2 = INDEFI + offset = NO + default: + goto err_ + } + } + + Memi[colors] = ncolors + call sfree (sp) + return (colors) + +err_ + call mfree (colors, TY_INT) + call sfree (sp) + call error (1, "Error in color specifications") +end + + +# MASKCOLOR_FREE -- Free the mask color object. + +procedure maskcolor_free (colors) + +pointer colors #I Mask colormap object + +begin + if (Memi[colors] == 0) + call evvfree (Memi[colors+1]) + call mfree (colors, TY_INT) +end + + +# MASKCOLOR -- Return a color for a mask value. + +int procedure maskcolor (colors, maskval) + +pointer colors #I Mask colormap object +int maskval #I Mask value +int color #O Color value + +int i, j, offset + +begin + # If there is no color array return the mask value. + if (Memi[colors] == 0) + return (maskval) + + color = Memi[colors+2] + offset = Memi[colors+3] + do i = 2, Memi[colors] { + j = 4 * i - 4 + if (maskval >= Memi[colors+j] && maskval <= Memi[colors+j+1]) { + color = Memi[colors+j+2] + offset = Memi[colors+j+3] + break + } + } + + if (offset == YES) + color = maskval + color + return (color) +end + + +procedure maskexprn (colors, maskvals, nmaskvals) + +pointer colors #I Mask colormap object +pointer maskvals #O Pointer to mask values (TY_INT) +int nmaskvals #I Number of mask values + +int i +pointer op, o, evvexpr() +errchk evvexpr + +int locpr +extern maskoperand, maskfunc + +begin + if (Memi[colors] > 0) + return + + op = Memi[colors+1] + O_LEN(op) = nmaskvals + O_VALP(op) = maskvals + + o = evvexpr (Memc[P2C(colors+2)], locpr(maskoperand), op, + locpr(maskfunc), NULL, O_FREEOP) + + #call amovi (Memi[O_VALP(o)], Memi[maskvals], nmaskvals) + switch (O_TYPE(o)) { + case TY_SHORT: + do i = 0, O_LEN(o) { + if (Memi[maskvals+i] > 0) + Memi[maskvals+i] = max (0, Mems[O_VALP(o)+i]) + } + case TY_BOOL, TY_INT: + do i = 0, O_LEN(o) { + if (Memi[maskvals+i] > 0) + Memi[maskvals+i] = max (0, Memi[O_VALP(o)+i]) + } + case TY_REAL: + do i = 0, O_LEN(o) { + if (Memi[maskvals+i] > 0) + Memi[maskvals+i] = max (0, nint(Memr[O_VALP(o)+i])) + } + case TY_DOUBLE: + do i = 0, O_LEN(o) { + if (Memi[maskvals+i] > 0) + Memi[maskvals+i] = max (0, nint(Memd[O_VALP(o)+i])) + } + } + + call evvfree (o) +end + + +# MASKOPERAND -- Handle mask expression operands. + +procedure maskoperand (op, operand, o) + +pointer op #I Input operand pointer +char operand[ARB] #I Operand name +pointer o #O Operand object + +char str[10] +int i, coltrans[9], strdic() +data coltrans/202,203,204,205,206,207,208,209,-1/ + +begin + if (operand[1] == '$') { + call xvv_initop (o, O_LEN(op), O_TYPE(op)) + call amovi (Memi[O_VALP(op)], Memi[O_VALP(o)], O_LEN(op)) + return + } + + call strcpy (operand, str, 11) + call strlwr (str) + i = strdic (str, str, 11, COLORS) + if (i > 0) { + call xvv_initop (o, 0, TY_INT) + O_VALI(o) = coltrans[i] + return + } + + call xvv_error1 ("Unknown mask operand %s", operand) +end + + +define KEYWORDS "|acenum|colors|" + +define F_ACENUM 1 # acenum (maskcodes,[flags]) +define F_COLORS 2 # colors (maskcodes,[col1,col2,col3]) + +# MASKFUNC -- Special processing functions. + +procedure maskfunc (data, func, args, nargs, val) + +pointer data #I client data +char func[ARB] #I function to be called +pointer args[ARB] #I pointer to arglist descriptor +int nargs #I number of arguments +pointer val #O output operand (function value) + +char str[12] +int i, j, c1, c2, c3 +int iresult, optype, oplen, opcode, v_nargs +double dresult + +bool strne() +int strdic(), btoi(), andi() +errchk malloc + +begin + # Lookup the function name in the dictionary. An exact match is + # required (strdic permits abbreviations). Abort if the function + # is not known. + + opcode = strdic (func, str, 12, KEYWORDS) + if (strne (func, str)) + call xvv_error1 ("unknown function `%s' called", func) + + # Verify correct number of arguments. + switch (opcode) { + case F_ACENUM, F_COLORS: + v_nargs = -1 + default: + v_nargs = 1 + } + + if (v_nargs > 0 && nargs != v_nargs) + call xvv_error2 ("function `%s' requires %d arguments", + func, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xvv_error2 ("function `%s' requires at least %d arguments", + func, abs(v_nargs)) + + # Group some common operations. + switch (opcode) { + case F_ACENUM: + # Check types of arguments. + if (O_TYPE(args[1]) != TY_INT) + call xvv_error1 ("error in argument types for function `%s'", + func) + if (nargs > 1) { + if (O_TYPE(args[2]) != TY_CHAR) + call xvv_error1 ( + "error in argument types for function `%s'", func) + } + optype = TY_INT + oplen = O_LEN(args[1]) + if (oplen > 0) + call malloc (iresult, oplen, TY_INT) + case F_COLORS: + # Check types of arguments. + do i = 1, nargs { + if (O_TYPE(args[i]) != TY_INT) + call xvv_error1 ("function `%s' requires integer arguments", + func) + } + optype = TY_INT + oplen = O_LEN(args[1]) + if (oplen > 0) + call malloc (iresult, oplen, TY_INT) + } + + # Evaluate the function. + switch (opcode) { + case F_ACENUM: + if (nargs == 1) + call strcpy ("BDEG", str, 12) + else + call strcpy (O_VALC(args[2]), str, 12) + call strupr (str) + c1 = 0; c2 = 0 + for (i=1; str[i]!=EOS; i=i+1) { + switch (str[i]) { + case 'B': + c1 = c1 + MASK_BP + case 'D': + c2 = c2 + MASK_GRW + MASK_SPLIT + case 'E': + c1 = c1 + MASK_BNDRY + case 'F': + c1 = c1 + MASK_BPFLAG + case 'G': + c1 = c1 + MASK_GRW + case 'S': + c1 = c1 + MASK_SPLIT + } + } + + if (oplen == 0) { + i = O_VALI(args[1]) + if (i > 10) { + if (andi(i,c1)!=0 && andi(i,c2)==0) + i = MNUM(i) + else + i = -1 + } else + i = 0 + iresult = i + } else { + do j = 0, oplen-1 { + i = Memi[O_VALP(args[1])+j] + if (i > 10) { + if (andi(i,c1)!=0) + i = MNUM(i) + else if (c2 != 0 && i <= MASK_NUM) + i = MNUM(i) + else + i = -1 + } else + i = 0 + Memi[iresult+j] = i + } + } + case F_COLORS: + c1 = 0; c2 = 204; c3 = 217 + if (nargs > 1) + c1 = O_VALI(args[2]) + if (nargs > 2) { + c2 = O_VALI(args[3]) + c3 = c2 + } + if (nargs > 3) + c3 = O_VALI(args[4]) + if (c3 < c2) { + i = c2; c2 = c3; c3 = i + } + c3 = c3 - c2 + 1 + + optype = TY_INT + oplen = O_LEN(args[1]) + if (oplen == 0) { + i = O_VALI(args[1]) + if (i == 0) + i = c1 + else if (i > 0) + i = c2 + mod (i-1, c3) + iresult = i + } else { + do j = 0, oplen-1 { + i = Memi[O_VALP(args[1])+j] + if (i == 0) + i = c1 + else if (i > 0) + i = c2 + mod (i-1, c3) + Memi[iresult+j] = i + } + } + } + + # Write the result to the output operand. Bool results are stored in + # iresult as an integer value, string results are stored in iresult as + # a pointer to the output string, and integer and real/double results + # are stored in iresult and dresult without any tricks. + + call xvv_initop (val, oplen, optype) + if (oplen == 0) { + switch (optype) { + case TY_BOOL: + O_VALI(val) = btoi (iresult != 0) + case TY_CHAR: + O_VALP(val) = iresult + case TY_INT: + O_VALI(val) = iresult + case TY_REAL: + O_VALR(val) = dresult + case TY_DOUBLE: + O_VALD(val) = dresult + } + } else { + O_VALP(val) = iresult + O_FLAGS(val) = O_FREEVAL + } + + # Free any storage used by the argument list operands. + do i = 1, nargs + call xvv_freeop (args[i]) + +end diff --git a/pkg/images/tv/display/maxmin.x b/pkg/images/tv/display/maxmin.x new file mode 100644 index 00000000..30f281f7 --- /dev/null +++ b/pkg/images/tv/display/maxmin.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# MAXMIN -- Get the minimum and maximum pixel values of an image. If valid +# header values are available they are used, otherwise the image is sampled +# on an even grid and the min and max values of this sample are returned. + +procedure maxmin (im, zmin, zmax, nsample_lines) + +pointer im +real zmin, zmax # min and max intensity values +int nsample_lines # amount of image to sample + +int step, ncols, nlines, sample_size, imlines, i +real minval, maxval +pointer imgl2r() +include "iis.com" + +begin + # Only calculate minimum, maximum pixel values if the current + # values are unknown, or if the image was modified since the + # old values were computed. + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + # Use min and max values in image header if they are up to date. + zmin = IM_MIN(im) + zmax = IM_MAX(im) + + } else { + zmin = MAX_REAL + zmax = -MAX_REAL + + # Try to include a constant number of pixels in the sample + # regardless of the image size. The entire image is used if we + # have a small image, and at least sample_lines lines are read + # if we have a large image. + + sample_size = iis_xdim * nsample_lines + imlines = min(nlines, max(nsample_lines, sample_size / ncols)) + step = nlines / (imlines + 1) + + do i = 1 + step, nlines, max (1, step) { + call alimr (Memr[imgl2r(im,i)], ncols, minval, maxval) + zmin = min (zmin, minval) + zmax = max (zmax, maxval) + } + } +end diff --git a/pkg/images/tv/display/mkpkg b/pkg/images/tv/display/mkpkg new file mode 100644 index 00000000..4d6d8885 --- /dev/null +++ b/pkg/images/tv/display/mkpkg @@ -0,0 +1,79 @@ +# Make the DISPLAY libraries. + +$checkout libds.a lib$ +$update libds.a +$checkin libds.a lib$ +$exit + +zzdebug: +zzdebug.e: + $omake zzdebug.x + $link zzdebug.o -lds -lstg -o zzdebug.e + ; + +libds.a: + dsmap.x + dspmmap.x \ + + dsulut.x display.h + findz.x iis.com iis.h + iisblk.x iis.h zdisplay.h + iiscls.x iis.com iis.h zdisplay.h + iisers.x iis.com iis.h zdisplay.h + iisflu.x iis.h zdisplay.h + iisgop.x iis.h + iishdr.x iis.com iis.h zdisplay.h + iisio.x iis.com iis.h zdisplay.h + iismtc.x iis.h zdisplay.h + iisofm.x iis.h zdisplay.h + iisopn.x iis.com iis.h imd.com zdisplay.h + iispio.x iis.com iis.h zdisplay.h + iisrcr.x iis.com iis.h zdisplay.h + iisrd.x iis.com iis.h zdisplay.h + iisrgb.x iis.h zdisplay.h + iissfr.x iis.com iis.h + iisstt.x iis.h zdisplay.h + iiswcr.x iis.com iis.h zdisplay.h + iiswnd.x iis.h zdisplay.h + iiswr.x iis.com iis.h zdisplay.h + iiswt.x iis.com iis.h zdisplay.h + iiszm.x iis.h zdisplay.h + imdgcur.x iis.com iis.h imd.com + imdgetwcs.x iis.com iis.h zdisplay.h + imdmapfr.x display.h iis.com iis.h \ + + imdmapping.x iis.com iis.h zdisplay.h + imdopen.x + imdputwcs.x display.h iis.com iis.h \ + + imdrcuro.x iis.com iis.h zdisplay.h + imdrcur.x + imdsetwcs.x iis.com iis.h + imdwcsver.x iis.com iis.h zdisplay.h + imdwcs.x + maskcolor.x ace.h + maxmin.x iis.com iis.h + sigl2.x + sigm2.x + t_dcontrol.x display.h iis.com iis.h zdisplay.h + t_display.x display.h gwindow.h iis.h \ + + zardim.x zdisplay.h + zawrim.x zdisplay.h + zawtim.x zdisplay.h + zblkim.x zdisplay.h + zclrim.x zdisplay.h + zclsim.x zdisplay.h + zersim.x zdisplay.h + zfrmim.x zdisplay.h + zmapim.x zdisplay.h + zmtcim.x zdisplay.h + zopnim.x zdisplay.h + zrcrim.x zdisplay.h + zrgbim.x zdisplay.h + zrmim.x zdisplay.h + zscale.x + zsttim.x iis.com iis.h + zwndim.x zdisplay.h + zzdebug.x + ; diff --git a/pkg/images/tv/display/sigl2.x b/pkg/images/tv/display/sigl2.x new file mode 100644 index 00000000..cbc465ec --- /dev/null +++ b/pkg/images/tv/display/sigl2.x @@ -0,0 +1,976 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help sigl2, sigl2_setup +.nf ___________________________________________________________________________ +SIGL2 -- Get a line from a spatially scaled 2-dimensional image. This procedure +works like the regular IMIO get line procedure, but rescales the input +2-dimensional image in either or both axes upon input. If the magnification +ratio required is greater than 0 and less than 2 then linear interpolation is +used to resample the image. If the magnification ratio is greater than or +equal to 2 then the image is block averaged by the smallest factor which +reduces the magnification to the range 0-2 and then interpolated back up to +the desired size. In some cases this will smooth the data slightly, but the +operation is efficient and avoids aliasing effects. + + si = sigl2_setup (im, x1,x2,nx,xblk, y1,y2,ny,yblk, order) + sigl2_free (si) + ptr = sigl2[sr] (si, linenumber) + +SIGL2_SETUP must be called to set up the transformations after mapping the +image and before performing any scaled i/o to the image. SIGL2_FREE must be +called when finished to return buffer space. +.endhelp ______________________________________________________________________ + +# Scaled image descriptor for 2-dim images + +define SI_LEN 16 +define SI_MAXDIM 2 # images of 2 dimensions supported +define SI_NBUFS 3 # nbuffers used by SIGL2 + +define SI_IM Memi[$1] # pointer to input image header +define SI_GRID Memi[$1+1+$2-1] # pointer to array of X coords +define SI_NPIX Memi[$1+3+$2-1] # number of X coords +define SI_BAVG Memi[$1+5+$2-1] # X block averaging factor +define SI_INTERP Memi[$1+7+$2-1] # interpolate X axis +define SI_BUF Memi[$1+9+$2-1] # line buffers +define SI_ORDER Memi[$1+12] # interpolator order, 0 or 1 +define SI_TYBUF Memi[$1+13] # buffer type +define SI_XOFF Memi[$1+14] # offset in input image to first X +define SI_INIT Memi[$1+15] # YES until first i/o is done + +define OUTBUF SI_BUF($1,3) + +define SI_TOL (1E-5) # close to a pixel +define INTVAL (abs ($1 - nint($1)) < SI_TOL) +define SWAPI {tempi=$2;$2=$1;$1=tempi} +define SWAPP {tempp=$2;$2=$1;$1=tempp} +define NOTSET (-9999) + +# SIGL2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute +# the block averaging factors (1 if no block averaging is required) and +# the sampling grid points, i.e., pixel coordinates of the output pixels in +# the input image. + +pointer procedure sigl2_setup (im, px1,px2,nx,xblk, py1,py2,ny,yblk, order) + +pointer im # the input image +real px1, px2 # range in X to be sampled on an even grid +int nx # number of output pixels in X +int xblk # blocking factor in x +real py1, py2 # range in Y to be sampled on an even grid +int ny # number of output pixels in Y +int yblk # blocking factor in y +int order # interpolator order (0=replicate, 1=linear) + +int npix, noldpix, nbavpix, i, j +int npts[SI_MAXDIM] # number of output points for axis +int blksize[SI_MAXDIM] # block averaging factor (npix per block) +real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels +real p1[SI_MAXDIM] # starting pixel coords in each axis +real p2[SI_MAXDIM] # ending pixel coords in each axis +real scalar, start +pointer si, gp + +begin + iferr (call calloc (si, SI_LEN, TY_STRUCT)) + call erract (EA_FATAL) + + SI_IM(si) = im + SI_NPIX(si,1) = nx + SI_NPIX(si,2) = ny + SI_ORDER(si) = order + SI_INIT(si) = YES + + p1[1] = px1 # X = index 1 + p2[1] = px2 + npts[1] = nx + blksize[1] = xblk + + p1[2] = py1 # Y = index 2 + p2[2] = py2 + npts[2] = ny + blksize[2] = yblk + + # Compute block averaging factors if not defined. + # If there is only one pixel then the block average is the average + # between the first and last point. + + do i = 1, SI_MAXDIM { + if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { + if (npts[i] == 1) + tau[i] = 0. + else + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else { + if (npts[i] == 1) { + tau[i] = 0. + blksize[i] = int (p2[i] - p1[i] + 1) + } else { + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + if (tau[i] >= 2.0) { + + # If nx or ny is not an integral multiple of the block + # averaging factor, noldpix is the next larger number + # which is an integral multiple. When the image is + # block averaged pixels will be replicated as necessary + # to fill the last block out to this size. + + blksize[i] = int (tau[i]) + npix = p2[i] - p1[i] + 1 + noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] + nbavpix = noldpix / blksize[i] + scalar = real (nbavpix - 1) / real (noldpix - 1) + p1[i] = (p1[i] - 1.0) * scalar + 1.0 + p2[i] = (p2[i] - 1.0) * scalar + 1.0 + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else + blksize[i] = 1 + } + } + } + + SI_BAVG(si,1) = blksize[1] + SI_BAVG(si,2) = blksize[2] + + if (IS_INDEFI (xblk)) + xblk = blksize[1] + if (IS_INDEFI (yblk)) + yblk = blksize[2] + + # Allocate and initialize the grid arrays, specifying the X and Y + # coordinates of each pixel in the output image, in units of pixels + # in the input (possibly block averaged) image. + + do i = 1, SI_MAXDIM { + # The X coordinate is special. We do not want to read entire + # input image lines if only a range of input X values are needed. + # Since the X grid vector passed to ALUI (the interpolator) must + # contain explicit offsets into the vector being interpolated, + # we must generate interpolator grid points starting near 1.0. + # The X origin, used to read the block averaged input line, is + # given by XOFF. + + if (i == 1) { + SI_XOFF(si) = int (p1[i]) + start = p1[1] - int (p1[i]) + 1.0 + } else + start = p1[i] + + # Do the axes need to be interpolated? + if (INTVAL(start) && INTVAL(tau[i])) + SI_INTERP(si,i) = NO + else + SI_INTERP(si,i) = YES + + # Allocate grid buffer and set the grid points. + iferr (call malloc (gp, npts[i], TY_REAL)) + call erract (EA_FATAL) + SI_GRID(si,i) = gp + if (SI_ORDER(si) <= 0) { + do j = 0, npts[i]-1 + Memr[gp+j] = int (start + (j * tau[i]) + 0.5) + } else { + do j = 0, npts[i]-1 + Memr[gp+j] = start + (j * tau[i]) + } + } + + return (si) +end + + +# SIGL2_FREE -- Free storage associated with an image opened for scaled +# input. This does not close and unmap the image. + +procedure sigl2_free (si) + +pointer si +int i + +begin + # Free SIGL2 buffers. + do i = 1, SI_NBUFS + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + + # Free GRID buffers. + do i = 1, SI_MAXDIM + if (SI_GRID(si,i) != NULL) + call mfree (SI_GRID(si,i), TY_REAL) + + call mfree (si, TY_STRUCT) +end + + +# SIGL2S -- Get a line of type short from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigl2s (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, buf_y[2], new_y[2], tempi, curbuf, altbuf +int npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blkavgs() +errchk si_blkavgs + +begin + npix = SI_NPIX(si,1) + + # Determine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blkavgs (SI_IM(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_SHORT) + SI_TYBUF(si) = TY_SHORT + buf_y[i] = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_SHORT) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == buf_y[i]) { + ; + } else if (new_y[i] == buf_y[altbuf]) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (buf_y[1], buf_y[2]) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blkavgs (SI_IM(si), x1, x2, new_y[i], + SI_BAVG(si,1), SI_BAVG(si,2)) + + if (SI_INTERP(si,1) == NO) { + call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) <= 0) { + call si_samples (Mems[rawline], Mems[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else { + call aluis (Mems[rawline], Mems[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + buf_y[i] = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from buf_y[1] to buf_y[2] is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - buf_y[1]) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) <= 0) + return (SI_BUF(si,1)) + else { + call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], + Mems[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLKAVGS -- Get a line from a block averaged image of type short. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blkavgs (im, x1, x2, y, xbavg, ybavg) + +pointer im # input image +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors + +real sum +pointer sp, a, b +int nblks_x, nblks_y, ncols, nlines, xoff, i, j +int first_line, nlines_in_sum, npix, nfull_blks, count +pointer imgs2s() +errchk imgs2s + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blkavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blkavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (imgs2s (im, xoff, xoff + npix - 1, y, y)) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blkavg: block number out of range") + + if (ybavg > 1) { + call salloc (b, nblks_x, TY_LONG) + call aclrl (Meml[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = imgs2s (im, xoff, xoff + npix - 1, i, i) + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + call abavs (Mems[a], Mems[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Mems[a+j-1] + count = count + 1 + } + Mems[a+nblks_x-1] = sum / count + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + + if (ybavg > 1) { + do j = 0, nblks_x-1 + Meml[b+j] = Meml[b+j] + Mems[a+j] + nlines_in_sum = nlines_in_sum + 1 + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + do i = 0, nblks_x-1 + Mems[a+i] = Meml[b+i] / real(nlines_in_sum) + } + + call sfree (sp) + return (a) +end + + +# SI_SAMPLES -- Resample a line via nearest neighbor, rather than linear +# interpolation (ALUI). The calling sequence is the same as for ALUIS. + +procedure si_samples (a, b, x, npix) + +short a[ARB], b[ARB] # input, output data arrays +real x[ARB] # sample grid +int npix, i + +begin + do i = 1, npix + b[i] = a[int(x[i])] +end + + +# SIGL2I -- Get a line of type int from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigl2i (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, buf_y[2], new_y[2], tempi, curbuf, altbuf +int npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blkavgi() +errchk si_blkavgi + +begin + npix = SI_NPIX(si,1) + + # Determine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blkavgi (SI_IM(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_INT) + SI_TYBUF(si) = TY_INT + buf_y[i] = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_INT) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == buf_y[i]) { + ; + } else if (new_y[i] == buf_y[altbuf]) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (buf_y[1], buf_y[2]) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blkavgi (SI_IM(si), x1, x2, new_y[i], + SI_BAVG(si,1), SI_BAVG(si,2)) + + if (SI_INTERP(si,1) == NO) { + call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) <= 0) { + call si_samplei (Memi[rawline], Memi[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else { + call aluii (Memi[rawline], Memi[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + buf_y[i] = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from buf_y[1] to buf_y[2] is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - buf_y[1]) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) <= 0) + return (SI_BUF(si,1)) + else { + call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], + Memi[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLKAVGI -- Get a line from a block averaged image of type integer. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blkavgi (im, x1, x2, y, xbavg, ybavg) + +pointer im # input image +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors + +real sum +pointer sp, a, b +int nblks_x, nblks_y, ncols, nlines, xoff, i, j +int first_line, nlines_in_sum, npix, nfull_blks, count +pointer imgs2i() +errchk imgs2i + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blkavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blkavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (imgs2i (im, xoff, xoff + npix - 1, y, y)) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blkavg: block number out of range") + + if (ybavg > 1) { + call salloc (b, nblks_x, TY_LONG) + call aclrl (Meml[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = imgs2i (im, xoff, xoff + npix - 1, i, i) + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + call abavi (Memi[a], Memi[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Memi[a+j-1] + count = count + 1 + } + Memi[a+nblks_x-1] = sum / count + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + + if (ybavg > 1) { + do j = 0, nblks_x-1 + Meml[b+j] = Meml[b+j] + Memi[a+j] + nlines_in_sum = nlines_in_sum + 1 + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + do i = 0, nblks_x-1 + Memi[a+i] = Meml[b+i] / real(nlines_in_sum) + } + + call sfree (sp) + return (a) +end + + +# SI_SAMPLEI -- Resample a line via nearest neighbor, rather than linear +# interpolation (ALUI). The calling sequence is the same as for ALUII. + +procedure si_samplei (a, b, x, npix) + +int a[ARB], b[ARB] # input, output data arrays +real x[ARB] # sample grid +int npix, i + +begin + do i = 1, npix + b[i] = a[int(x[i])] +end + + +# SIGL2R -- Get a line of type real from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigl2r (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, buf_y[2], new_y[2], tempi, curbuf, altbuf +int npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blkavgr() +errchk si_blkavgr + +begin + npix = SI_NPIX(si,1) + + # Deterine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blkavgr (SI_IM(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_REAL) + SI_TYBUF(si) = TY_REAL + buf_y[i] = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_REAL) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == buf_y[i]) { + ; + } else if (new_y[i] == buf_y[altbuf]) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (buf_y[1], buf_y[2]) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blkavgr (SI_IM(si), x1, x2, new_y[i], + SI_BAVG(si,1), SI_BAVG(si,2)) + + if (SI_INTERP(si,1) == NO) { + call amovr (Memr[rawline], Memr[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) <= 0) { + call si_sampler (Memr[rawline], Memr[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else { + call aluir (Memr[rawline], Memr[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + buf_y[i] = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from buf_y[1] to buf_y[2] is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - buf_y[1]) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) <= 0) + return (SI_BUF(si,1)) + else { + call awsur (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], + Memr[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLKAVGR -- Get a line from a block averaged image of type real. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blkavgr (im, x1, x2, y, xbavg, ybavg) + +pointer im # input image +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors + +int nblks_x, nblks_y, ncols, nlines, xoff, i, j +int first_line, nlines_in_sum, npix, nfull_blks, count +real sum +pointer sp, a, b +pointer imgs2r() +errchk imgs2r + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blkavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blkavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (imgs2r (im, xoff, xoff + npix - 1, y, y)) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blkavg: block number out of range") + + call salloc (b, nblks_x, TY_REAL) + + if (ybavg > 1) { + call aclrr (Memr[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = imgs2r (im, xoff, xoff + npix - 1, i, i) + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + call abavr (Memr[a], Memr[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Memr[a+j-1] + count = count + 1 + } + Memr[a+nblks_x-1] = sum / count + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + if (ybavg > 1) { + call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) + nlines_in_sum = nlines_in_sum + 1 + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) + call adivkr (Memr[b], real(nlines_in_sum), Memr[a], nblks_x) + + call sfree (sp) + return (a) +end + + +# SI_SAMPLER -- Resample a line via nearest neighbor, rather than linear +# interpolation (ALUI). The calling sequence is the same as for ALUIR. + +procedure si_sampler (a, b, x, npix) + +real a[ARB], b[ARB] # input, output data arrays +real x[ARB] # sample grid +int npix, i + +begin + do i = 1, npix + b[i] = a[int(x[i])] +end diff --git a/pkg/images/tv/display/sigm2.x b/pkg/images/tv/display/sigm2.x new file mode 100644 index 00000000..41a3b5da --- /dev/null +++ b/pkg/images/tv/display/sigm2.x @@ -0,0 +1,1110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help sigm2, sigm2_setup +.nf ___________________________________________________________________________ +SIGM2 -- Get a line from a spatially scaled 2-dimensional image. This procedure +works like the regular IMIO get line procedure, but rescales the input +2-dimensional image in either or both axes upon input. If the magnification +ratio required is greater than 0 and less than 2 then linear interpolation is +used to resample the image. If the magnification ratio is greater than or +equal to 2 then the image is block averaged by the smallest factor which +reduces the magnification to the range 0-2 and then interpolated back up to +the desired size. In some cases this will smooth the data slightly, but the +operation is efficient and avoids aliasing effects. + + si = sigm2_setup (im,pm, x1,x2,nx,xblk, y1,y2,ny,yblk, order) + sigm2_free (si) + ptr = sigm2[sr] (si, linenumber) + +SIGM2_SETUP must be called to set up the transformations after mapping the +image and before performing any scaled i/o to the image. SIGM2_FREE must be +called when finished to return buffer space. + +The SIGM routines are like SIGL routines except for the addition of +interpolation over bad pixels and order=-1 takes the maximum rather +than the average when doing block averaging or interpolation. +.endhelp ______________________________________________________________________ + +# Scaled image descriptor for 2-dim images + +define SI_LEN 19 +define SI_MAXDIM 2 # images of 2 dimensions supported +define SI_NBUFS 3 # nbuffers used by SIGL2 + +define SI_IM Memi[$1] # pointer to input image header +define SI_FP Memi[$1+1] # pointer to fixpix structure +define SI_GRID Memi[$1+2+$2-1] # pointer to array of X coords +define SI_NPIX Memi[$1+4+$2-1] # number of X coords +define SI_BAVG Memi[$1+6+$2-1] # X block averaging factor +define SI_INTERP Memi[$1+8+$2-1] # interpolate X axis +define SI_BUF Memi[$1+10+$2-1]# line buffers +define SI_BUFY Memi[$1+13+$2-1]# Y values of buffers +define SI_ORDER Memi[$1+15] # interpolator order +define SI_TYBUF Memi[$1+16] # buffer type +define SI_XOFF Memi[$1+17] # offset in input image to first X +define SI_INIT Memi[$1+18] # YES until first i/o is done + +define OUTBUF SI_BUF($1,3) + +define SI_TOL (1E-5) # close to a pixel +define INTVAL (abs ($1 - nint($1)) < SI_TOL) +define SWAPI {tempi=$2;$2=$1;$1=tempi} +define SWAPP {tempp=$2;$2=$1;$1=tempp} +define NOTSET (-9999) + +# SIGM2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute +# the block averaging factors (1 if no block averaging is required) and +# the sampling grid points, i.e., pixel coordinates of the output pixels in +# the input image. + +pointer procedure sigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) + +pointer im # the input image +pointer pm # pixel mask +real px1, px2 # range in X to be sampled on an even grid +int nx # number of output pixels in X +int xblk # blocking factor in x +real py1, py2 # range in Y to be sampled on an even grid +int ny # number of output pixels in Y +int yblk # blocking factor in y +int order # interpolator order (0=replicate, 1=linear) + +int npix, noldpix, nbavpix, i, j +int npts[SI_MAXDIM] # number of output points for axis +int blksize[SI_MAXDIM] # block averaging factor (npix per block) +real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels +real p1[SI_MAXDIM] # starting pixel coords in each axis +real p2[SI_MAXDIM] # ending pixel coords in each axis +real scalar, start +pointer si, gp, xt_fpinit() + +begin + iferr (call calloc (si, SI_LEN, TY_STRUCT)) + call erract (EA_FATAL) + + SI_IM(si) = im + SI_FP(si) = xt_fpinit (pm, 1, INDEFI) + SI_NPIX(si,1) = nx + SI_NPIX(si,2) = ny + SI_ORDER(si) = order + SI_INIT(si) = YES + + p1[1] = px1 # X = index 1 + p2[1] = px2 + npts[1] = nx + blksize[1] = xblk + + p1[2] = py1 # Y = index 2 + p2[2] = py2 + npts[2] = ny + blksize[2] = yblk + + # Compute block averaging factors if not defined. + # If there is only one pixel then the block average is the average + # between the first and last point. + + do i = 1, SI_MAXDIM { + if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { + if (npts[i] == 1) + tau[i] = 0. + else + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else { + if (npts[i] == 1) { + tau[i] = 0. + blksize[i] = int (p2[i] - p1[i] + 1 + SI_TOL) + } else { + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + if (tau[i] >= 2.0) { + + # If nx or ny is not an integral multiple of the block + # averaging factor, noldpix is the next larger number + # which is an integral multiple. When the image is + # block averaged pixels will be replicated as necessary + # to fill the last block out to this size. + + blksize[i] = int (tau[i] + SI_TOL) + npix = p2[i] - p1[i] + 1 + noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] + nbavpix = noldpix / blksize[i] + scalar = real (nbavpix - 1) / real (noldpix - 1) + p1[i] = (p1[i] - 1.0) * scalar + 1.0 + p2[i] = (p2[i] - 1.0) * scalar + 1.0 + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else + blksize[i] = 1 + } + } + } + + SI_BAVG(si,1) = blksize[1] + SI_BAVG(si,2) = blksize[2] + +# if (IS_INDEFI (xblk)) +# xblk = blksize[1] +# if (IS_INDEFI (yblk)) +# yblk = blksize[2] + + # Allocate and initialize the grid arrays, specifying the X and Y + # coordinates of each pixel in the output image, in units of pixels + # in the input (possibly block averaged) image. + + do i = 1, SI_MAXDIM { + # The X coordinate is special. We do not want to read entire + # input image lines if only a range of input X values are needed. + # Since the X grid vector passed to ALUI (the interpolator) must + # contain explicit offsets into the vector being interpolated, + # we must generate interpolator grid points starting near 1.0. + # The X origin, used to read the block averaged input line, is + # given by XOFF. + + if (i == 1) { + SI_XOFF(si) = int (p1[i] + SI_TOL) + start = p1[1] - int (p1[i] + SI_TOL) + 1.0 + } else + start = p1[i] + + # Do the axes need to be interpolated? + if (INTVAL(start) && INTVAL(tau[i])) + SI_INTERP(si,i) = NO + else + SI_INTERP(si,i) = YES + + # Allocate grid buffer and set the grid points. + iferr (call malloc (gp, npts[i], TY_REAL)) + call erract (EA_FATAL) + SI_GRID(si,i) = gp + if (SI_ORDER(si) <= 0) { + do j = 0, npts[i]-1 + Memr[gp+j] = int (start + (j * tau[i]) + 0.5 + SI_TOL) + } else { + do j = 0, npts[i]-1 + Memr[gp+j] = start + (j * tau[i]) + } + } + + return (si) +end + + +# SIGM2_FREE -- Free storage associated with an image opened for scaled +# input. This does not close and unmap the image. + +procedure sigm2_free (si) + +pointer si +int i + +begin + # Free fixpix structure. + call xt_fpfree (SI_FP(si)) + + # Free SIGM2 buffers. + do i = 1, SI_NBUFS + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + + # Free GRID buffers. + do i = 1, SI_MAXDIM + if (SI_GRID(si,i) != NULL) + call mfree (SI_GRID(si,i), TY_REAL) + + call mfree (si, TY_STRUCT) +end + + +# SIGM2S -- Get a line of type short from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigm2s (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, new_y[2], tempi, curbuf, altbuf +int nraw, npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blmavgs() +errchk si_blmavgs + +begin + nraw = IM_LEN(SI_IM(si),1) + npix = SI_NPIX(si,1) + + # Determine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_SHORT) + SI_TYBUF(si) = TY_SHORT + SI_BUFY(si,i) = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_SHORT) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == SI_BUFY(si,i)) { + ; + } else if (new_y[i] == SI_BUFY(si,altbuf)) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, + new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) + + if (SI_INTERP(si,1) == NO) { + call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) == 0) { + call si_samples (Mems[rawline], Mems[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else if (SI_ORDER(si) == -1) { + call si_maxs (Mems[rawline], nraw, + Memr[SI_GRID(si,1)], Mems[SI_BUF(si,i)], npix) + } else { + call aluis (Mems[rawline], Mems[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + SI_BUFY(si,i) = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - SI_BUFY(si,1)) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) + return (SI_BUF(si,1)) + else if (SI_ORDER(si) == -1) { + call amaxs (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], + Mems[OUTBUF(si)], npix) + return (OUTBUF(si)) + } else { + call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], + Mems[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLMAVGS -- Get a line from a block averaged image of type short. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blmavgs (im, fp, x1, x2, y, xbavg, ybavg, order) + +pointer im # input image +pointer fp # fixpix structure +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors +int order # averaging option + +real sum +short blkmax +pointer sp, a, b +int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k +int first_line, nlines_in_sum, npix, nfull_blks, count +pointer xt_fps() +errchk xt_fps + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blmavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blmavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (xt_fps (fp, im, y, NULL) + xoff - 1) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blmavg: block number out of range") + + if (ybavg > 1) { + call salloc (b, nblks_x, TY_LONG) + call aclrl (Meml[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = xt_fps (fp, im, i, NULL) + xoff - 1 + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + if (order == -1) { + blk1 = a + do j = 1, nfull_blks { + blk2 = blk1 + xbavg + blkmax = Mems[blk1] + do k = blk1+1, blk2-1 + blkmax = max (blkmax, Mems[k]) + Mems[a+j-1] = blkmax + blk1 = blk2 + } + } else + call abavs (Mems[a], Mems[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + if (order == -1) { + blkmax = Mems[blk1] + do k = blk1+1, a+npix-1 + blkmax = max (blkmax, Mems[k]) + Mems[a+j-1] = blkmax + } else { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Mems[a+j-1] + count = count + 1 + } + Mems[a+nblks_x-1] = sum / count + } + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + + if (ybavg > 1) { + if (order == -1) { + do j = 0, nblks_x-1 + Meml[b+j] = max (Meml[b+j], long (Mems[a+j])) + } else { + do j = 0, nblks_x-1 + Meml[b+j] = Meml[b+j] + Mems[a+j] + nlines_in_sum = nlines_in_sum + 1 + } + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + if (order == -1) { + do i = 0, nblks_x-1 + Mems[a+i] = Meml[b+i] + } else { + do i = 0, nblks_x-1 + Mems[a+i] = Meml[b+i] / real(nlines_in_sum) + } + } + + call sfree (sp) + return (a) +end + + +# SI_MAXS -- Resample a line via maximum value. + +procedure si_maxs (a, na, x, b, nb) + +short a[na] # input array +int na # input size +real x[nb] # sample grid +short b[nb] # output arrays +int nb # output size + +int i + +begin + do i = 1, nb + b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) +end + + +# SIGM2I -- Get a line of type short from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigm2i (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, new_y[2], tempi, curbuf, altbuf +int nraw, npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blmavgi() +errchk si_blmavgi + +begin + nraw = IM_LEN(SI_IM(si),1) + npix = SI_NPIX(si,1) + + # Determine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_INT) + SI_TYBUF(si) = TY_INT + SI_BUFY(si,i) = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_INT) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == SI_BUFY(si,i)) { + ; + } else if (new_y[i] == SI_BUFY(si,altbuf)) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, + new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) + + if (SI_INTERP(si,1) == NO) { + call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) == 0) { + call si_samplei (Memi[rawline], Memi[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else if (SI_ORDER(si) == -1) { + call si_maxi (Memi[rawline], nraw, + Memr[SI_GRID(si,1)], Memi[SI_BUF(si,i)], npix) + } else { + call aluii (Memi[rawline], Memi[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + SI_BUFY(si,i) = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - SI_BUFY(si,1)) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) + return (SI_BUF(si,1)) + else if (SI_ORDER(si) == -1) { + call amaxi (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], + Memi[OUTBUF(si)], npix) + return (OUTBUF(si)) + } else { + call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], + Memi[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLMAVGI -- Get a line from a block averaged image of type integer. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blmavgi (im, fp, x1, x2, y, xbavg, ybavg, order) + +pointer im # input image +pointer fp # fixpix structure +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors +int order # averaging option + +real sum +int blkmax +pointer sp, a, b +int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k +int first_line, nlines_in_sum, npix, nfull_blks, count +pointer xt_fpi() +errchk xt_fpi + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blmavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blmavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (xt_fpi (fp, im, y, NULL) + xoff - 1) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blmavg: block number out of range") + + if (ybavg > 1) { + call salloc (b, nblks_x, TY_LONG) + call aclrl (Meml[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = xt_fpi (fp, im, i, NULL) + xoff - 1 + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + if (order == -1) { + blk1 = a + do j = 1, nfull_blks { + blk2 = blk1 + xbavg + blkmax = Memi[blk1] + do k = blk1+1, blk2-1 + blkmax = max (blkmax, Memi[k]) + Memi[a+j-1] = blkmax + blk1 = blk2 + } + } else + call abavi (Memi[a], Memi[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + if (order == -1) { + blkmax = Memi[blk1] + do k = blk1+1, a+npix-1 + blkmax = max (blkmax, Memi[k]) + Memi[a+j-1] = blkmax + } else { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Memi[a+j-1] + count = count + 1 + } + Memi[a+nblks_x-1] = sum / count + } + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + + if (ybavg > 1) { + if (order == -1) { + do j = 0, nblks_x-1 + Meml[b+j] = max (Meml[b+j], long (Memi[a+j])) + } else { + do j = 0, nblks_x-1 + Meml[b+j] = Meml[b+j] + Memi[a+j] + nlines_in_sum = nlines_in_sum + 1 + } + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + if (order == -1) { + do i = 0, nblks_x-1 + Memi[a+i] = Meml[b+i] + } else { + do i = 0, nblks_x-1 + Memi[a+i] = Meml[b+i] / real(nlines_in_sum) + } + } + + call sfree (sp) + return (a) +end + + +# SI_MAXI -- Resample a line via maximum value. + +procedure si_maxi (a, na, x, b, nb) + +int a[na] # input array +int na # input size +real x[nb] # sample grid +int b[nb] # output arrays +int nb # output size + +int i + +begin + do i = 1, nb + b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) +end + + +# SIGM2R -- Get a line of type real from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigm2r (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, new_y[2], tempi, curbuf, altbuf +int nraw, npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blmavgr() +errchk si_blmavgr + +begin + nraw = IM_LEN(SI_IM(si)) + npix = SI_NPIX(si,1) + + # Deterine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blmavgr (SI_IM(si), SI_FP(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_REAL) + SI_TYBUF(si) = TY_REAL + SI_BUFY(si,i) = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_REAL) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == SI_BUFY(si,i)) { + ; + } else if (new_y[i] == SI_BUFY(si,altbuf)) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blmavgr (SI_IM(si), SI_FP(si), x1, x2, + new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) + + if (SI_INTERP(si,1) == NO) { + call amovr (Memr[rawline], Memr[SI_BUF(si,i)], npix) + } else if (SI_ORDER(si) == 0) { + call si_sampler (Memr[rawline], Memr[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } else if (SI_ORDER(si) == -1) { + call si_maxr (Memr[rawline], nraw, + Memr[SI_GRID(si,1)], Memr[SI_BUF(si,i)], npix) + } else { + call aluir (Memr[rawline], Memr[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + SI_BUFY(si,i) = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - SI_BUFY(si,1)) + weight_2 = 1.0 - weight_1 + + if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) + return (SI_BUF(si,1)) + else if (SI_ORDER(si) == -1) { + call amaxr (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], + Memr[OUTBUF(si)], npix) + return (OUTBUF(si)) + } else { + call awsur (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], + Memr[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLMAVGR -- Get a line from a block averaged image of type short. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blmavgr (im, fp, x1, x2, y, xbavg, ybavg, order) + +pointer im # input image +pointer fp # fixpix structure +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors +int order # averaging option + +int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k +int first_line, nlines_in_sum, npix, nfull_blks, count +real sum, blkmax +pointer sp, a, b +pointer xt_fpr() +errchk xt_fpr + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blmavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blmavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (xt_fpr (fp, im, y, NULL) + xoff - 1) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blmavg: block number out of range") + + call salloc (b, nblks_x, TY_REAL) + + if (ybavg > 1) { + call aclrr (Memr[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = xt_fpr (fp, im, i, NULL) + xoff - 1 + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + if (order == -1) { + blk1 = a + do j = 1, nfull_blks { + blk2 = blk1 + xbavg + blkmax = Memr[blk1] + do k = blk1+1, blk2-1 + blkmax = max (blkmax, Memr[k]) + Memr[a+j-1] = blkmax + blk1 = blk2 + } + } else + call abavr (Memr[a], Memr[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + if (order == -1) { + blkmax = Memr[blk1] + do k = blk1+1, a+npix-1 + blkmax = max (blkmax, Memr[k]) + Memr[a+j-1] = blkmax + } else { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Memr[a+j-1] + count = count + 1 + } + Memr[a+nblks_x-1] = sum / count + } + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + if (ybavg > 1) { + if (order == -1) + call amaxr (Memr[a], Memr[b], Memr[b], nblks_x) + else { + call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) + nlines_in_sum = nlines_in_sum + 1 + } + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + if (order == -1) + call amovr (Memr[b], Memr[a], nblks_x) + else + call adivkr (Memr[b], real(nlines_in_sum), Memr[a], nblks_x) + } + + call sfree (sp) + return (a) +end + + +# SI_MAXR -- Resample a line via maximum value. + +procedure si_maxr (a, na, x, b, nb) + +real a[na] # input array +int na # input size +real x[nb] # sample grid +real b[nb] # output arrays +int nb # output size + +int i + +begin + do i = 1, nb + b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) +end diff --git a/pkg/images/tv/display/t_dcontrol.x b/pkg/images/tv/display/t_dcontrol.x new file mode 100644 index 00000000..8b68a66b --- /dev/null +++ b/pkg/images/tv/display/t_dcontrol.x @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "display.h" +include "zdisplay.h" +include "iis.h" + +# DCONTROL -- Control functions for the image display device. This has been +# cleaned up to eliminate unecessary operations and make it more efficient, +# but is only a throwaway program which breaks a few rules. This file contains +# some explicitly IIS dependent code. + +procedure t_dcontrol() + +real rate +int zoom, type, status +pointer sp, device, devinfo, tty +bool erase, window, rgb_window, blink, match, roam +int red_frame, green_frame, blue_frame, prim_frame, alt_frame, nframes +int red_chan[2], green_chan[2], blue_chan[2], prim_chan[2], alt_chan[2] +char type_string[SZ_FNAME], map_string[SZ_FNAME] +int chan[2], alt1[2], alt2[2] alt3[2] alt4[2] + +real clgetr() +pointer ttygdes() +bool clgetb(), streq(), ttygetb() +int clgeti(), clscan(), nscan(), envgets(), ttygets(), ttygeti(), btoi() +string stdimage "stdimage" +include "iis.com" +define err_ 91 + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (devinfo, SZ_LINE, TY_CHAR) + + # Get display parameters. + + call clgstr ("type", type_string, SZ_FNAME) + call clgstr ("map", map_string, SZ_FNAME) + + red_frame = clgeti ("red_frame") + green_frame = clgeti ("green_frame") + blue_frame = clgeti ("blue_frame") + prim_frame = clgeti ("frame") + alt_frame = clgeti ("alternate") + + zoom = clgeti ("zoom") + rate = clgetr ("rate") + erase = clgetb ("erase") + window = clgetb ("window") + rgb_window = clgetb ("rgb_window") + blink = clgetb ("blink") + match = clgetb ("match") + roam = clgetb ("roam") + + # Remember current frame. + call clputi ("frame", prim_frame) + call iis_setframe (prim_frame) + + # Get device information. + call clgstr ("device", Memc[device], SZ_FNAME) + if (streq (device, stdimage)) { + if (envgets (stdimage, Memc[device], SZ_FNAME) <= 0) + call syserrs (SYS_ENVNF, stdimage) + } + tty = ttygdes (Memc[device]) + if (ttygets (tty, "DD", Memc[devinfo], SZ_LINE) <= 0) + call error (1, "no `DD' entry in graphcap entry for device") + + # Pick up the frame size and configuration number. + iis_xdim = ttygeti (tty, "xr") + iis_ydim = ttygeti (tty, "yr") + iis_config = ttygeti (tty, "cn") + iis_server = btoi (ttygetb (tty, "LC")) + + # Verify operation is legal on device. + if (iis_server == YES) { + if (!streq (type_string, "frame")) + goto err_ + if (!streq (map_string, "mono")) + goto err_ + if (erase) + ; + if (roam) + goto err_ + if (window) + goto err_ + if (rgb_window) + goto err_ + if (blink) + goto err_ + if (match) { +err_ call eprintf ("operation not supported for display device %s\n") + call pargstr (Memc[device]) + call ttycdes (tty) + call sfree (sp) + return + } + } + + # Access display. + call strpak (Memc[devinfo], Memc[devinfo], SZ_LINE) + call iisopn (Memc[devinfo], READ_WRITE, chan) + if (chan[1] == ERR) + call error (2, "cannot open display") + + call fseti (STDOUT, F_FLUSHNL, YES) + + red_chan[1] = FRTOCHAN(red_frame) + green_chan[1] = FRTOCHAN(green_frame) + blue_chan[1] = FRTOCHAN(blue_frame) + prim_chan[1] = FRTOCHAN(prim_frame) + alt_chan[1] = FRTOCHAN(alt_frame) + + red_chan[2] = MONO + green_chan[2] = MONO + blue_chan[2] = MONO + prim_chan[2] = MONO + alt_chan[2] = MONO + + # Execute the selected control functions. + if (streq (type_string, "rgb")) { + type = RGB + call zrgbim (red_chan, green_chan, blue_chan) + } else if (streq (type_string, "frame")) { + type = FRAME + call zfrmim (prim_chan) + } else + call error (3, "unknown display type") + + # Set display mapping. + call zmapim (prim_chan, map_string) + + if (erase) { + switch (type) { + case RGB: + call zersim (red_chan) + call zersim (green_chan) + call zersim (blue_chan) + case FRAME: + call zersim (prim_chan) + } + + } else { + if (roam) { + call printf ("Roam display and exit by pushing any button\n") + call zrmim (prim_chan, zoom) + } + + if (window) { + call printf ("Window display and exit by pushing any button\n") + call zwndim (prim_chan) + } + + if (rgb_window) { + call printf ("Window display and exit by pushing any button\n") + call zwndim3 (red_chan, green_chan, blue_chan) + } + + if (match) + call zmtcim (alt_chan, prim_chan) + + if (blink) { + if (clscan ("alternate") != EOF) { + call gargi (alt1[1]) + call gargi (alt2[1]) + call gargi (alt3[1]) + call gargi (alt4[1]) + nframes = nscan() + + alt1[1] = FRTOCHAN(alt1[1]) + alt2[1] = FRTOCHAN(alt2[1]) + alt3[1] = FRTOCHAN(alt3[1]) + alt4[1] = FRTOCHAN(alt4[1]) + + alt1[2] = MONO + alt2[2] = MONO + alt3[2] = MONO + alt4[2] = MONO + + call printf ("Exit by pushing any button\n") + call zblkim (alt1, alt2, alt3, alt4, nframes, rate) + } + } + } + + # Close display. + call zclsim (chan[1], status) + call ttycdes (tty) + call sfree (sp) +end diff --git a/pkg/images/tv/display/t_display.x b/pkg/images/tv/display/t_display.x new file mode 100644 index 00000000..f4156f39 --- /dev/null +++ b/pkg/images/tv/display/t_display.x @@ -0,0 +1,885 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include "display.h" +include "gwindow.h" +include "iis.h" + +# DISPLAY - Display an image. The specified image section is mapped into +# the specified section of an image display frame. The mapping involves +# a linear transformation in X and Y and a linear or logarithmic transformation +# in Z (greyscale). Images of all pixel datatypes are supported, and there +# no upper limit on the size of an image. The display device is interfaced +# to FIO as a file and is accessed herein via IMIO as just another imagefile. +# The physical characteristics of the display (i.e., X, Y, and Z resolution) +# are taken from the image header. The display frame buffer is the pixel +# storage "file". + +procedure t_display() + +char image[SZ_FNAME] # Image to display +int frame # Display frame +int erase # Erase frame? + +int i +pointer sp, wdes, im, ds + +bool clgetb() +int clgeti(), btoi(), imd_wcsver(), imtlen(), imtgetim() +pointer immap(), imd_mapframe1(), imtopenp() +errchk immap, imd_mapframe1 +errchk ds_getparams, ds_setwcs, ds_load_display, ds_erase_border + +begin + call smark (sp) + call salloc (wdes, LEN_WDES, TY_STRUCT) + call aclri (Memi[wdes], LEN_WDES) + + # Open input imagefile. + im = imtopenp ("image") + if (imtlen (im) != 1) + call error (1, "Only one image may be displayed") + i = imtgetim (im, image, SZ_FNAME) + call imtclose (im) + #call clgstr ("image", image, SZ_FNAME) + im = immap (image, READ_ONLY, 0) + if (IM_NDIM(im) <= 0) + call error (1, "image has no pixels") + + # Query server to get the WCS version, this also tells us whether + # we can use the all 16 supported frames. + if (imd_wcsver() == 0) + call clputi ("display.frame.p_max", 4) + else + call clputi ("display.frame.p_max", 16) + + + # Open display device as an image. + frame = clgeti ("frame") + W_FRAME(wdes) = frame + + erase = btoi (clgetb ("erase")) + if (erase == YES) + ds = imd_mapframe1 (frame, WRITE_ONLY, + btoi (clgetb ("select_frame")), erase) + else + ds = imd_mapframe1 (frame, READ_WRITE, + btoi (clgetb ("select_frame")), erase) + + # Get display parameters and set up transformation. + call ds_getparams (im, ds, wdes) + + # Compute and output the screen to image pixel WCS. + call ds_setwcs (im, ds, wdes, image, frame) + + # Display the image and zero the border if necessary. + call ds_load_display (im, ds, wdes) + if (!clgetb ("erase") && clgetb ("border_erase")) + call ds_erase_border (im, ds, wdes) + + # Free storage. + call maskcolor_free (W_OCOLORS(wdes)) + call maskcolor_free (W_BPCOLORS(wdes)) + do i = 0, W_MAXWC + if (W_UPTR(W_WC(wdes,i)) != NULL) + call ds_ulutfree (W_UPTR(W_WC(wdes,i))) + call imunmap (ds) + call imunmap (im) + + call sfree (sp) +end + + +# DS_GETPARAMS -- Get the parameters controlling how the image is mapped +# into the display frame. Set up the transformations and save in the graphics +# descriptor file. If "repeat" mode is enabled, read the graphics descriptor +# file and reuse the transformations therein. + +procedure ds_getparams (im, ds, wdes) + +pointer im, ds, wdes #I Image, display, and graphics descriptors + +bool fill, zscale_flag, zrange_flag, zmap_flag +real xcenter, ycenter, xsize, ysize +real xmag, ymag, xscale, yscale, pxsize, pysize +real z1, z2, contrast +int nsample, ncols, nlines +pointer wnwin, wdwin, wwwin, wipix, wdpix, zpm, bpm +pointer sp, str, ztrans, lutfile + +int clgeti(), clgwrd(), nowhite() +real clgetr() +pointer maskcolor_map(), ds_pmmap(), zsc_pmsection() +pointer ds_ulutalloc() +bool streq(), clgetb() +errchk maskcolor_map, ds_pmmap, zsc_pmsection, mzscale + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (ztrans, SZ_FNAME, TY_CHAR) + + # Get overlay mask and colors. + call clgstr ("overlay", W_OVRLY(wdes), W_SZSTRING) + call clgstr ("ocolors", Memc[str], SZ_LINE) + W_OCOLORS(wdes) = maskcolor_map (Memc[str]) + + # Get bad pixel mask. + call clgstr ("bpmask", W_BPM(wdes), W_SZSTRING) + W_BPDISP(wdes) = clgwrd ("bpdisplay", Memc[str], SZ_LINE, BPDISPLAY) + call clgstr ("bpcolors", Memc[str], SZ_LINE) + W_BPCOLORS(wdes) = maskcolor_map (Memc[str]) + + # Determine the display window into which the image is to be mapped + # in normalized device coordinates. + + xcenter = max(0.0, min(1.0, clgetr ("xcenter"))) + ycenter = max(0.0, min(1.0, clgetr ("ycenter"))) + xsize = max(0.0, min(1.0, clgetr ("xsize"))) + ysize = max(0.0, min(1.0, clgetr ("ysize"))) + + # Set up a new graphics descriptor structure defining the coordinate + # transformation used to map the image into the display frame. + + wnwin = W_WC(wdes,W_NWIN) + wdwin = W_WC(wdes,W_DWIN) + wwwin = W_WC(wdes,W_WWIN) + wipix = W_WC(wdes,W_IPIX) + wdpix = W_WC(wdes,W_DPIX) + + # Determine X and Y scaling ratios required to map the image into the + # normalized display window. If spatial scaling is not desired filling + # must be disabled and XMAG and YMAG must be set to 1.0 in the + # parameter file. Fill mode will always produce an aspect ratio of 1; + # if nonequal scaling is required then the magnification ratios must + # be set explicitly by the user. + + fill = clgetb ("fill") + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + if (fill) { + # Compute scale in units of window coords per data pixel required + # to scale image to fit window. + + xmag = (IM_LEN(ds,1) * xsize) / ncols + ymag = (IM_LEN(ds,2) * ysize) / nlines + + if (xmag > ymag) + xmag = ymag + else + ymag = xmag + + } else { + # Compute scale required to provide image magnification ratios + # specified by the user. Magnification is specified in units of + # display pixels, i.e, a magnification ratio of 1.0 means that + # image pixels will map to display pixels without scaling. + + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + } + + xscale = 1.0 / (IM_LEN(ds,1) / xmag) + yscale = 1.0 / (IM_LEN(ds,2) / ymag) + + # Set device window limits in normalized device coordinates. + # World coord system 0 is used for the device window. + + W_XS(wnwin) = xcenter - xsize / 2.0 + W_XE(wnwin) = xcenter + xsize / 2.0 + W_YS(wnwin) = ycenter - ysize / 2.0 + W_YE(wnwin) = ycenter + ysize / 2.0 + + # Set pixel coordinates of window. + # If the image is too large to fit in the window given the scaling + # factors XSCALE and YSCALE, the following will set starting and ending + # pixel coordinates in the interior of the image. If the image is too + # small to fill the window then the pixel coords will reference beyond + # the bounds of the image. Note that the 0.5 is because NDC has + # the screen corner at 0 while screen pixels have the corner at 0.5. + + pxsize = xsize / xscale + pysize = ysize / yscale + + W_XS(wdwin) = (ncols / 2.0) - (pxsize / 2.0) + 0.5 + W_XE(wdwin) = W_XS(wdwin) + pxsize + W_YS(wdwin) = (nlines / 2.0) - (pysize / 2.0) + 0.5 + W_YE(wdwin) = W_YS(wdwin) + pysize + + # Compute X and Y magnification ratios required to map image into + # the device window in device pixel units. + + xmag = (W_XE(wnwin)-W_XS(wnwin))*IM_LEN(ds,1)/(W_XE(wdwin)-W_XS(wdwin)) + ymag = (W_YE(wnwin)-W_YS(wnwin))*IM_LEN(ds,2)/(W_YE(wdwin)-W_YS(wdwin)) + + # Compute the coordinates of the image section to be displayed. + # Round down if upper pixel is exactly at one-half. + + W_XS(wipix) = max (1, nint(W_XS(wdwin))) + W_XE(wipix) = min (ncols, nint(W_XE(wdwin)-1.01)) + W_YS(wipix) = max (1, nint(W_YS(wdwin))) + W_YE(wipix) = min (nlines, nint(W_YE(wdwin)-1.01)) + + # Now compute the image and display pixels to be used. + # The image may be truncated to fit in the display window. + # These are integer coordinates at the pixel centers. + + pxsize = W_XE(wipix) - W_XS(wipix) + 1 + pysize = W_YE(wipix) - W_YS(wipix) + 1 + xcenter = (W_XE(wnwin) + W_XS(wnwin)) / 2.0 * IM_LEN(ds,1) + 0.5 + ycenter = (W_YE(wnwin) + W_YS(wnwin)) / 2.0 * IM_LEN(ds,2) + 0.5 + + #W_XS(wdpix) = max (1, nint (xcenter - (pxsize/2.0*xmag) + 0.5)) + W_XS(wdpix) = max (1, int (xcenter - (pxsize/2.0*xmag) + 0.5)) + W_XE(wdpix) = min (IM_LEN(ds,1), nint (W_XS(wdpix)+pxsize*xmag - 1.01)) + #W_YS(wdpix) = max (1, nint (ycenter - (pysize/2.0*ymag) + 0.5)) + W_YS(wdpix) = max (1, int (ycenter - (pysize/2.0*ymag) + 0.5)) + W_YE(wdpix) = min (IM_LEN(ds,2), nint (W_YS(wdpix)+pysize*ymag - 1.01)) + + # Now adjust the display window to be consistent with the image and + # display pixels to be used. + + W_XS(wdwin) = W_XS(wnwin) * IM_LEN(ds,1) + 0.5 + W_XE(wdwin) = W_XE(wnwin) * IM_LEN(ds,1) + 0.5 + W_YS(wdwin) = W_YS(wnwin) * IM_LEN(ds,2) + 0.5 + W_YE(wdwin) = W_YE(wnwin) * IM_LEN(ds,2) + 0.5 + W_XS(wdwin) = (W_XS(wipix)-0.5) + (W_XS(wdwin)-(W_XS(wdpix)-0.5))/xmag + W_XE(wdwin) = (W_XS(wipix)-0.5) + (W_XE(wdwin)-(W_XS(wdpix)-0.5))/xmag + W_YS(wdwin) = (W_YS(wipix)-0.5) + (W_YS(wdwin)-(W_YS(wdpix)-0.5))/ymag + W_YE(wdwin) = (W_YS(wipix)-0.5) + (W_YE(wdwin)-(W_YS(wdpix)-0.5))/ymag + + # Order of interpolator used for spatial transformation. + W_XT(wdwin) = max(0, min(1, clgeti ("order"))) + W_YT(wdwin) = W_XT(wdwin) + + # Determine the greyscale transformation. + call clgstr ("ztrans", Memc[ztrans], SZ_FNAME) + if (streq (Memc[ztrans], "log")) + W_ZT(wdwin) = W_LOG + else if (streq (Memc[ztrans], "linear")) + W_ZT(wdwin) = W_LINEAR + else if (streq (Memc[ztrans], "none")) + W_ZT(wdwin) = W_UNITARY + else if (streq (Memc[ztrans], "user")) { + W_ZT(wdwin) = W_USER + call salloc (lutfile, SZ_FNAME, TY_CHAR) + call clgstr ("lutfile", Memc[lutfile], SZ_FNAME) + W_UPTR(wdwin) = ds_ulutalloc (Memc[lutfile], z1, z2) + } else { + call eprintf ("Bad greylevel transformation '%s'\n") + call pargstr (Memc[ztrans]) + W_ZT(wdwin) = W_LINEAR + } + + # The zscale, and zrange parameters determine the algorithms for + # determining Z1 and Z2, the range of input z values to be mapped + # into the fixed range of display greylevels. If sampling and no + # sample mask is given then create one as a subsampled image section. + # If greyscale mapping is disabled the zscale and zrange options are + # disabled. Greyscale mapping can also be disabled by turning off + # zscale and zrange and setting Z1 and Z2 to the device greyscale min + # and max values, producing a unitary transformation. + + if (W_ZT(wdwin) == W_UNITARY || W_ZT(wdwin) == W_USER) { + zscale_flag = false + zrange_flag = false + zmap_flag = false + } else { + zmap_flag = true + zscale_flag = clgetb ("zscale") + if (!zscale_flag) + zrange_flag = clgetb ("zrange") + } + + if (zscale_flag || (zrange_flag && IM_LIMTIME(im) < IM_MTIME(im))) { + call clgstr ("zmask", W_ZPM(wdes), W_SZSTRING) + nsample = max (100, clgeti ("nsample")) + if (nowhite (W_ZPM(wdes), W_ZPM(wdes), W_SZSTRING) > 0) { + if (W_ZPM(wdes) == '[') + zpm = zsc_pmsection (W_ZPM(wdes), im) + else + zpm = ds_pmmap (W_ZPM(wdes), im) + } else + zpm = NULL + iferr (bpm = ds_pmmap (W_BPM(wdes), im)) { + call erract (EA_WARN) + bpm = NULL + } + } + + if (zscale_flag) { + # Autoscaling is desired. Compute Z1 and Z2 which straddle the + # median computed by sampling a portion of the image. + + contrast = clgetr ("contrast") + call mzscale (im, zpm, bpm, contrast, nsample, z1, z2) + if (zpm != NULL) + call imunmap (zpm) + if (bpm != NULL) + call imunmap (bpm) + + } else if (zrange_flag) { + # Use the limits in the header if current otherwise get the + # minimum and maximum of the sample mask. + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + z1 = IM_MIN(im) + z2 = IM_MAX(im) + } else { + call mzscale (im, zpm, bpm, 0., nsample, z1, z2) + if (zpm != NULL) + call imunmap (zpm) + if (bpm != NULL) + call imunmap (bpm) + } + + } else if (zmap_flag) { + z1 = clgetr ("z1") + z2 = clgetr ("z2") + } else { + z1 = IM_MIN(ds) + z2 = IM_MAX(ds) + } + + W_ZS(wdwin) = z1 + W_ZE(wdwin) = z2 + + call printf ("z1=%g z2=%g\n") + call pargr (z1) + call pargr (z2) + call flush (STDOUT) + + # The user world coordinate system should be set from the CTRAN + # structure in the image header, but for now we just make it equal + # to the pixel coordinate system. + + call amovi (Memi[wdwin], Memi[wwwin], LEN_WC) + W_UPTR(wwwin) = NULL # should not copy pointers!! + call sfree (sp) +end + + +# DS_SETWCS -- Compute the rotation matrix needed to convert screen coordinates +# (zero indexed, y-flipped) to image pixel coordinates, allowing both for the +# transformation from screen space to the image section being displayed, and +# from the image section to the physical input image. +# +# NOTE -- This code assumes that the display device is zero-indexed and +# y-flipped; this is usually the case, but should be parameterized in the +# graphcap. This code also assumes that the full device screen is being used, +# and that we are not assigning multiple WCS to different regions of the screen. + +procedure ds_setwcs (im, ds, wdes, image, frame) + +pointer im, ds, wdes # image, display, and coordinate descriptors +char image[SZ_FNAME] # image section name +int frame # frame + +real a, b, c, d, tx, ty +int ip, i, j, axis[2] +real sx, sy +int dx, dy, snx, sny, dnx, dny +pointer sp, imname, title, wnwin, wdwin +pointer src, dest, region, objref +long lv[IM_MAXDIM], pv1[IM_MAXDIM], pv2[IM_MAXDIM] + +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + call salloc (region, SZ_FNAME, TY_CHAR) + call salloc (objref, SZ_FNAME, TY_CHAR) + + # Compute the rotation matrix needed to transform screen pixel coords + # to image section coords. + + wnwin = W_WC(wdes,W_NWIN) + wdwin = W_WC(wdes,W_DWIN) + + # X transformation. + a = (W_XE(wdwin)-W_XS(wdwin))/((W_XE(wnwin)-W_XS(wnwin))*IM_LEN(ds,1)) + c = 0.0 # not rotated, cross term is zero + tx = W_XS(wdwin) - a * (W_XS(wnwin) * IM_LEN(ds,1)) + + # Y transformation. + b = 0.0 # not rotated, cross term is zero + d = (W_YE(wdwin)-W_YS(wdwin))/((W_YE(wnwin)-W_YS(wnwin))*IM_LEN(ds,2)) + ty = W_YS(wdwin) - d * (W_YS(wnwin) * IM_LEN(ds,2)) + + # Now allow for the Y-flip (origin at upper left in display window). + d = -d + ty = W_YE(wdwin) - d * ((1.0 - W_YE(wnwin)) * IM_LEN(ds,2)) + + # Now translate the screen corner to the center of the screen pixel. + tx = tx + 0.5 * a + ty = ty + 0.5 * d + + # Determine the logical to physical mapping by evaluating two points. + # and determining the axis reduction if any. pv1 will be the + # offset and pv2-pv1 will be the scale. + + call aclrl (pv1, IM_MAXDIM) + call aclrl (lv, IM_MAXDIM) + call imaplv (im, lv, pv1, 2) + call amovkl (long(1), lv, IM_MAXDIM) + call aclrl (pv2, IM_MAXDIM) + call imaplv (im, lv, pv2, 2) + + i = 1 + axis[1] = 1; axis[2] = 2 + do j = 1, IM_MAXDIM + if (pv1[j] != pv2[j]) { + axis[i] = j + i = i + 1 + } + + pv2[axis[1]] = (pv2[axis[1]] - pv1[axis[1]]) + pv2[axis[2]] = (pv2[axis[2]] - pv1[axis[2]]) + + # These imply a new rotation matrix which we won't bother to work out + # separately here. Multiply the two rotation matrices and add the + # translation vectors to get the overall transformation from screen + # coordinates to image coordinates. + a = a * pv2[axis[1]] + d = d * pv2[axis[2]] + tx = tx * pv2[axis[1]] + pv1[axis[1]] + ty = ty * pv2[axis[2]] + pv1[axis[2]] + + # Get the image name (minus image section) and + # title string (minus any newline. + call ds_gimage (im, image, Memc[imname], SZ_FNAME) + call strcpy (IM_TITLE(im), Memc[title], SZ_LINE) + for (ip=title; Memc[ip] != '\n' && Memc[ip] != EOS; ip=ip+1) + ; + Memc[ip] = EOS + + + # Define the mapping from the image pixels to frame buffer pixels. + src = W_WC(wdes,W_IPIX) + sx = W_XS(src) + sy = W_YS(src) + snx = (W_XE(src) - W_XS(src) + 1) + sny = (W_YE(src) - W_YS(src) + 1) + + dest = W_WC(wdes,W_DPIX) + dx = W_XS(dest) + dy = W_YS(dest) + dnx = (W_XE(dest) - W_XS(dest) + 1) + dny = (W_YE(dest) - W_YS(dest) + 1) + + # For a single image display the 'region' is fixed. The object ref + # is the fully defined image node!prefix path, including any sections. + # We need a special kludge to keep backward compatability with the + # use of "dev$pix" as the standard test image name. + call strcpy ("image", Memc[region], SZ_FNAME) + if (streq (image, "dev$pix")) + call fpathname ("dev$pix.imh", Memc[objref], SZ_PATHNAME) + else + call fpathname (image, Memc[objref], SZ_PATHNAME) + + # Add the mapping info to be written with the WCS. + call imd_setmapping (Memc[region], sx, sy, snx, sny, + dx, dy, dnx, dny, Memc[objref]) + + # Write the WCS. + call imd_putwcs (ds, frame, Memc[imname], Memc[title], + a, b, c, d, tx, ty, W_ZS(wdwin), W_ZE(wdwin), W_ZT(wdwin)) + + call sfree (sp) +end + + +# DS_GIMAGE -- Convert input image section name to a 2D physical image section. + +procedure ds_gimage (im, input, output, maxchar) + +pointer im #I IMIO pointer +char input[ARB] #I Input image name +char output[maxchar] #O Output image name +int maxchar #I Maximum characters in output name. + +int i, fd +pointer sp, section, lv, pv1, pv2 + +int stropen(), strlen() +bool streq() + +begin + call smark (sp) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (lv, IM_MAXDIM, TY_LONG) + call salloc (pv1, IM_MAXDIM, TY_LONG) + call salloc (pv2, IM_MAXDIM, TY_LONG) + + # Get endpoint coordinates in original image. + call amovkl (long(1), Meml[lv], IM_MAXDIM) + call aclrl (Meml[pv1], IM_MAXDIM) + call imaplv (im, Meml[lv], Meml[pv1], 2) + call amovl (IM_LEN(im,1), Meml[lv], IM_NDIM(im)) + call aclrl (Meml[pv2], IM_MAXDIM) + call imaplv (im, Meml[lv], Meml[pv2], 2) + + # Set image section. + fd = stropen (Memc[section], SZ_FNAME, NEW_FILE) + call fprintf (fd, "[") + do i = 1, IM_MAXDIM { + if (Meml[pv1+i-1] != Meml[pv2+i-1]) + call fprintf (fd, "*") + else if (Meml[pv1+i-1] != 0) { + call fprintf (fd, "%d") + call pargi (Meml[pv1+i-1]) + } else + break + call fprintf (fd, ",") + } + call close (fd) + i = strlen (Memc[section]) + Memc[section+i-1] = ']' + + if (streq ("[*,*]", Memc[section])) + Memc[section] = EOS + + # Strip existing image section and add new section. +# call imgimage (input, output, maxchar) +# call strcat (Memc[section], output, maxchar) + + if (Memc[section] == EOS) + call imgimage (input, output, maxchar) + else + call strcpy (input, output, maxchar) + + call sfree (sp) +end + + +# DS_LOAD_DISPLAY -- Map an image into the display window. In general this +# involves independent linear transformations in the X, Y, and Z (greyscale) +# dimensions. If a spatial dimension is larger than the display window then +# the image is block averaged. If a spatial dimension or a block averaged +# dimension is smaller than the display window then linear interpolation is +# used to expand the image. Both the input image and the output device appear +# to us as images, accessed via IMIO. All spatial scaling is +# handled by the "scaled input" package, i.e., SIGM2[SR]. Our task is to +# get lines from the scaled input image, transform the greyscale if necessary, +# and write the lines to the output device. + +procedure ds_load_display (im, ds, wdes) + +pointer im # input image +pointer ds # output image +pointer wdes # graphics window descriptor + +real z1, z2, dz1, dz2, px1, px2, py1, py2 +int i, order, zt, wx1, wx2, wy1, wy2, wy, nx, ny, xblk, yblk, color +pointer wdwin, wipix, wdpix, ovrly, bpm, pm, uptr +pointer in, out, si, si_ovrly, si_bpovrly, ocolors, bpcolors, rtemp +bool unitary_greyscale_transformation +short lut1, lut2, dz1_s, dz2_s, z1_s, z2_s + +bool fp_equalr() +int imstati(), maskcolor() +pointer ds_pmmap(), imps2s(), imps2r() +pointer sigm2s(), sigm2i(), sigm2r(), sigm2_setup() +errchk ds_pmmap, imps2s, imps2r, sigm2s, sigm2i, sigm2r, sigm2_setup +errchk maskexprn + +begin + wdwin = W_WC(wdes,W_DWIN) + wipix = W_WC(wdes,W_IPIX) + wdpix = W_WC(wdes,W_DPIX) + + # Set image and display pixels. + px1 = nint (W_XS(wipix)) + px2 = nint (W_XE(wipix)) + py1 = nint (W_YS(wipix)) + py2 = nint (W_YE(wipix)) + wx1 = nint (W_XS(wdpix)) + wx2 = nint (W_XE(wdpix)) + wy1 = nint (W_YS(wdpix)) + wy2 = nint (W_YE(wdpix)) + + z1 = W_ZS(wdwin) + z2 = W_ZE(wdwin) + zt = W_ZT(wdwin) + uptr = W_UPTR(wdwin) + order = max (W_XT(wdwin), W_YT(wdwin)) + + # Setup scaled input and masks. + si = NULL + si_ovrly = NULL + si_bpovrly = NULL + nx = wx2 - wx1 + 1 + ny = wy2 - wy1 + 1 + xblk = INDEFI + yblk = INDEFI + + ocolors = W_OCOLORS(wdes) + iferr (ovrly = ds_pmmap (W_OVRLY(wdes), im)) { + call erract (EA_WARN) + ovrly = NULL + } + if (ovrly != NULL) { + xblk = INDEFI + yblk = INDEFI + si_ovrly = sigm2_setup (ovrly, NULL, px1,px2,nx,xblk, + py1,py2,ny,yblk, -1) + } + + bpcolors = W_BPCOLORS(wdes) + switch (W_BPDISP(wdes)) { + case BPDNONE: + si = sigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) + case BPDOVRLY: + si = sigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) + iferr (bpm = ds_pmmap (W_BPM(wdes), im)) + bpm = NULL + if (bpm != NULL) + si_bpovrly = sigm2_setup (bpm, NULL, px1,px2,nx,xblk, + py1,py2,ny,yblk, -1) + case BPDINTERP: + iferr (bpm = ds_pmmap (W_BPM(wdes), im)) + bpm = NULL + if (bpm != NULL) + pm = imstati (bpm, IM_PMDES) + else + pm = NULL + si = sigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) + } + + # The device IM_MIN and IM_MAX parameters define the acceptable range + # of greyscale values for the output device (e.g., 0-255 for most 8-bit + # display devices). Values Z1 and Z2 are mapped linearly or + # logarithmically into IM_MIN and IM_MAX. + + dz1 = IM_MIN(ds) + dz2 = IM_MAX(ds) + if (fp_equalr (z1, z2)) { + z1 = z1 - 1 + z2 = z2 + 1 + } + + # If the user specifies the transfer function, verify that the + # intensity and greyscale are in range. + + if (zt == W_USER) { + call alims (Mems[uptr], U_MAXPTS, lut1, lut2) + dz1_s = short (dz1) + dz2_s = short (dz2) + if (lut2 < dz1_s || lut1 > dz2_s) + call eprintf ("User specified greyscales out of range\n") + if (z2 < IM_MIN(im) || z1 > IM_MAX(im)) + call eprintf ("User specified intensities out of range\n") + } + + # Type short pixels are treated as a special case to minimize vector + # operations for such images (which are common). If the image pixels + # are either short or real then only the ALTR (greyscale transformation) + # vector operation is required. The ALTR operator linearly maps + # greylevels in the range Z1:Z2 to DZ1:DZ2, and does a floor ceiling + # of DZ1:DZ2 on all pixels outside the range. If unity mapping is + # employed the data is simply copied, i.e., floor ceiling constraints + # are not applied. This is very fast and will produce a contoured + # image on the display which will be adequate for some applications. + + if (zt == W_UNITARY) { + unitary_greyscale_transformation = true + } else if (zt == W_LINEAR) { + unitary_greyscale_transformation = + (fp_equalr(z1,dz1) && fp_equalr(z2,dz2)) + } else + unitary_greyscale_transformation = false + + if (IM_PIXTYPE(im) == TY_SHORT && zt != W_LOG) { + z1_s = z1; z2_s = z2 + if (z1_s == z2_s) { + z1_s = z1_s - 1 + z2_s = z2_s + 1 + } + + for (wy=wy1; wy <= wy2; wy=wy+1) { + in = sigm2s (si, wy - wy1 + 1) + out = imps2s (ds, wx1, wx2, wy, wy) + + if (unitary_greyscale_transformation) { + call amovs (Mems[in], Mems[out], nx) + } else if (zt == W_USER) { + dz1_s = U_Z1; dz2_s = U_Z2 + call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s,dz2_s) + call aluts (Mems[out], Mems[out], nx, Mems[uptr]) + } else { + dz1_s = dz1; dz2_s = dz2 + call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s,dz2_s) + } + + if (si_ovrly != NULL) { + in = sigm2i (si_ovrly, wy - wy1 + 1) + call maskexprn (ocolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (ocolors, Memi[in+i]) + if (color >= 0) + Mems[out+i] = color + } + } + } + if (si_bpovrly != NULL) { + in = sigm2i (si_bpovrly, wy - wy1 + 1) + call maskexprn (bpcolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (bpcolors, Memi[in+i]) + if (color >= 0) + Mems[out+i] = color + } + } + } + } + + } else if (zt == W_USER) { + call salloc (rtemp, nx, TY_REAL) + + for (wy=wy1; wy <= wy2; wy=wy+1) { + in = sigm2r (si, wy - wy1 + 1) + out = imps2s (ds, wx1, wx2, wy, wy) + + call amapr (Memr[in], Memr[rtemp], nx, z1, z2, + real(U_Z1), real(U_Z2)) + call achtrs (Memr[rtemp], Mems[out], nx) + call aluts (Mems[out], Mems[out], nx, Mems[uptr]) + + if (si_ovrly != NULL) { + in = sigm2i (si_ovrly, wy - wy1 + 1) + call maskexprn (ocolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (ocolors, Memi[in+i]) + if (color >= 0) + Mems[out+i] = color + } + } + } + if (si_bpovrly != NULL) { + in = sigm2i (si_bpovrly, wy - wy1 + 1) + call maskexprn (bpcolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (bpcolors, Memi[in+i]) + if (color >= 0) + Mems[out+i] = color + } + } + } + } + + } else { + for (wy=wy1; wy <= wy2; wy=wy+1) { + in = sigm2r (si, wy - wy1 + 1) + out = imps2r (ds, wx1, wx2, wy, wy) + + if (unitary_greyscale_transformation) { + call amovr (Memr[in], Memr[out], nx) + } else if (zt == W_LOG) { + call amapr (Memr[in], Memr[out], nx, + z1, z2, 1.0, 10.0 ** MAXLOG) + do i = 0, nx-1 + Memr[out+i] = log10 (Memr[out+i]) + call amapr (Memr[out], Memr[out], nx, + 0.0, real(MAXLOG), dz1, dz2) + } else + call amapr (Memr[in], Memr[out], nx, z1, z2, dz1, dz2) + + if (si_ovrly != NULL) { + in = sigm2i (si_ovrly, wy - wy1 + 1) + call maskexprn (ocolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (ocolors, Memi[in+i]) + if (color >= 0) + Memr[out+i] = color + } + } + } + if (si_bpovrly != NULL) { + in = sigm2i (si_bpovrly, wy - wy1 + 1) + call maskexprn (bpcolors, in, nx) + do i = 0, nx-1 { + if (Memi[in+i] != 0) { + color = maskcolor (bpcolors, Memi[in+i]) + if (color >= 0) + Memr[out+i] = color + } + } + } + } + } + + call sigm2_free (si) + if (si_ovrly != NULL) + call sigm2_free (si_ovrly) + if (si_bpovrly != NULL) + call sigm2_free (si_bpovrly) + if (ovrly != NULL) + call imunmap (ovrly) + if (bpm != NULL) + call imunmap (bpm) +end + + +# DS_ERASE_BORDER -- Zero the border of the window if the frame has not been +# erased, and if the displayed section does not occupy the full window. +# It would be more efficient to do this while writing the greyscale data to +# the output image, but that would complicate the display procedures and frames +# are commonly erased before displaying an image. + +procedure ds_erase_border (im, ds, wdes) + +pointer im # input image +pointer ds # output image (display) +pointer wdes # window descriptor + +int wx1,wx2,wy1,wy2 # section of display window filled by image data +int dx1,dx2,dy1,dy2 # coords of full display window in device pixels +int i, nx +pointer wdwin, wdpix +pointer imps2s() +errchk imps2s + +begin + wdwin = W_WC(wdes,W_DWIN) + wdpix = W_WC(wdes,W_DPIX) + + # Set display pixels and display window pixels. + wx1 = nint (W_XS(wdpix)) + wx2 = nint (W_XE(wdpix)) + wy1 = nint (W_YS(wdpix)) + wy2 = nint (W_YE(wdpix)) + dx1 = max (1, nint (W_XS(wdwin))) + dx2 = min (IM_LEN(ds,1), nint (W_XE(wdwin) - 0.01)) + dy1 = max (1, nint (W_YS(wdwin))) + dy2 = min (IM_LEN(ds,2), nint (W_YE(wdwin) - 0.01)) + nx = dx2 - dx1 + 1 + + # Erase lower margin. + for (i=dy1; i < wy1; i=i+1) + call aclrs (Mems[imps2s (ds, dx1, dx2, i, i)], nx) + + # Erase left and right margins. By doing the right margin of a line + # immediately after the left margin we have a high liklihood that the + # display line will still be in the FIO buffer. + + for (i=wy1; i <= wy2; i=i+1) { + if (dx1 < wx1) + call aclrs (Mems[imps2s (ds, dx1, wx1-1, i, i)], wx1 - dx1) + if (wx2 < dx2) + call aclrs (Mems[imps2s (ds, wx2+1, dx2, i, i)], dx2 - wx2) + } + + # Erase upper margin. + for (i=wy2+1; i <= dy2; i=i+1) + call aclrs (Mems[imps2s (ds, dx1, dx2, i, i)], nx) +end diff --git a/pkg/images/tv/display/zardim.x b/pkg/images/tv/display/zardim.x new file mode 100644 index 00000000..e09c4b10 --- /dev/null +++ b/pkg/images/tv/display/zardim.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZARDIM -- Read data from a binary file display device. + +procedure zardim (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisrd (chan, buf, nbytes, offset) + } +end diff --git a/pkg/images/tv/display/zawrim.x b/pkg/images/tv/display/zawrim.x new file mode 100644 index 00000000..a7219b07 --- /dev/null +++ b/pkg/images/tv/display/zawrim.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZAWRIM -- Write data to a binary file display device. + +procedure zawrim (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iiswr (chan, buf, nbytes, offset) + } +end diff --git a/pkg/images/tv/display/zawtim.x b/pkg/images/tv/display/zawtim.x new file mode 100644 index 00000000..13756adc --- /dev/null +++ b/pkg/images/tv/display/zawtim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZAWTIM -- Wait for an image display frame which is addressable as +# a binary file. + +procedure zawtim (chan, nbytes) + +int chan[ARB], nbytes +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iiswt (chan, nbytes) + } +end diff --git a/pkg/images/tv/display/zblkim.x b/pkg/images/tv/display/zblkim.x new file mode 100644 index 00000000..55041809 --- /dev/null +++ b/pkg/images/tv/display/zblkim.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZBLKIM -- Blink binary file display device (millisecond time resolution). + +procedure zblkim (chan1, chan2, chan3, chan4, nframes, rate) + +int chan1[ARB] +int chan2[ARB] +int chan3[ARB] +int chan4[ARB] +int nframes +real rate +int device + +begin + device = chan1[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisblk (chan1, chan2, chan3, chan4, nframes, rate) + } +end diff --git a/pkg/images/tv/display/zclrim.x b/pkg/images/tv/display/zclrim.x new file mode 100644 index 00000000..268123cc --- /dev/null +++ b/pkg/images/tv/display/zclrim.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZCLRIM -- Color window binary file display device. + +procedure zclrim (chan) + +int chan[ARB] +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisclr (chan) + } +end diff --git a/pkg/images/tv/display/zclsim.x b/pkg/images/tv/display/zclsim.x new file mode 100644 index 00000000..8f3f34b0 --- /dev/null +++ b/pkg/images/tv/display/zclsim.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZCLSIM -- Close an image display frame which is addressable as +# a binary file. + +procedure zclsim (chan, status) + +int chan[ARB] +int status +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iiscls (chan, status) + default: + status = ERR + } +end diff --git a/pkg/images/tv/display/zdisplay.h b/pkg/images/tv/display/zdisplay.h new file mode 100644 index 00000000..b55b94dc --- /dev/null +++ b/pkg/images/tv/display/zdisplay.h @@ -0,0 +1,6 @@ +# Display devices defined by OS + +define IIS "/dev/iis" # IIS display device +define IIS_CHAN 1 # Device channel identifier +define DEVCODE 100 # Channel = DEVCODE * DEVCHAN +define FRTOCHAN (IIS_CHAN*DEVCODE+($1)) diff --git a/pkg/images/tv/display/zersim.x b/pkg/images/tv/display/zersim.x new file mode 100644 index 00000000..c1b280e4 --- /dev/null +++ b/pkg/images/tv/display/zersim.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZERSIM -- Erase binary file display device. + +procedure zersim (chan) + +int chan[ARB] +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisers (chan) + } +end diff --git a/pkg/images/tv/display/zfrmim.x b/pkg/images/tv/display/zfrmim.x new file mode 100644 index 00000000..de2bfee2 --- /dev/null +++ b/pkg/images/tv/display/zfrmim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZFRMIM -- Set FRAME display. + +procedure zfrmim (chan) + +int chan[ARB] + +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisrgb (chan, chan, chan) + } +end diff --git a/pkg/images/tv/display/zmapim.x b/pkg/images/tv/display/zmapim.x new file mode 100644 index 00000000..5c3e663a --- /dev/null +++ b/pkg/images/tv/display/zmapim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZMAPIM -- Set display map. + +procedure zmapim (chan, maptype) + +int chan[ARB] +char maptype[ARB] +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisofm (maptype) + } +end diff --git a/pkg/images/tv/display/zmtcim.x b/pkg/images/tv/display/zmtcim.x new file mode 100644 index 00000000..11dddb65 --- /dev/null +++ b/pkg/images/tv/display/zmtcim.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZMTCIM -- Match lut to frame. + +procedure zmtcim (chan1, chan2) + +int chan1[ARB], chan2[ARB] +int device + +begin + device = chan1[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iismtc (chan1, chan2) + } +end diff --git a/pkg/images/tv/display/zopnim.x b/pkg/images/tv/display/zopnim.x new file mode 100644 index 00000000..ddd18d3a --- /dev/null +++ b/pkg/images/tv/display/zopnim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZOPNIM -- Open an image display frame which is addressable as +# a binary file. + +procedure zopnim (devinfo, mode, chan) + +char devinfo[ARB] # packed devinfo string +int mode # access mode +int chan + +int iischan[2] # Kludge + +begin + call iisopn (devinfo, mode, iischan) + chan = iischan[1] +end diff --git a/pkg/images/tv/display/zrcrim.x b/pkg/images/tv/display/zrcrim.x new file mode 100644 index 00000000..3f4f939b --- /dev/null +++ b/pkg/images/tv/display/zrcrim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZRCRIM -- Read Cursor from binary file display device. + +procedure zrcrim (chan, xcur, ycur) + +int chan[ARB] +int status, xcur, ycur +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisrcr (status, xcur, ycur) + } +end diff --git a/pkg/images/tv/display/zrgbim.x b/pkg/images/tv/display/zrgbim.x new file mode 100644 index 00000000..04c0e147 --- /dev/null +++ b/pkg/images/tv/display/zrgbim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZRGBIM -- Set RGB display. + +procedure zrgbim (red_chan, green_chan, blue_chan) + +int red_chan[ARB], green_chan[ARB], blue_chan[ARB] + +int device + +begin + device = red_chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisrgb (red_chan, green_chan, blue_chan) + } +end diff --git a/pkg/images/tv/display/zrmim.x b/pkg/images/tv/display/zrmim.x new file mode 100644 index 00000000..f26ee6ef --- /dev/null +++ b/pkg/images/tv/display/zrmim.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZRMIM -- Zoom and roam display. + +procedure zrmim (chan, zfactor) + +int chan[ARB] +int zfactor +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iisrm (zfactor) + } +end diff --git a/pkg/images/tv/display/zscale.x b/pkg/images/tv/display/zscale.x new file mode 100644 index 00000000..abbf2ecb --- /dev/null +++ b/pkg/images/tv/display/zscale.x @@ -0,0 +1,623 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include + +# User callable routines. +# ZSCALE -- Sample an image and compute greyscale limits. +# MZSCALE -- Sample an image with pixel masks and compute greyscale limits. +# ZSC_PMSECTION -- Create a pixel mask from an image section. +# ZSC_ZLIMITS -- Compute Z transform limits from a sample of pixels. + + +# ZSCALE -- Sample an image and compute greyscale limits. +# A sample mask is created based on the input parameters and then +# MZSCALE is called. + +procedure zscale (im, z1, z2, contrast, optimal_sample_size, len_stdline) + +pointer im # image to be sampled +real z1, z2 # output min and max greyscale values +real contrast # adj. to slope of transfer function +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +int nc, nl +pointer sp, section, zpm, zsc_pmsection() +errchk zsc_pmsection, mzscale + +begin + call smark (sp) + call salloc (section, SZ_FNAME, TY_CHAR) + + # Make the sample image section. + switch (IM_NDIM(im)) { + case 1: + call sprintf (Memc[section], SZ_FNAME, "[*]") + default: + nc = max (1, min (IM_LEN(im,1), len_stdline)) + nl = max (1, min (IM_LEN(im,2), optimal_sample_size / nc)) + call sprintf (Memc[section], SZ_FNAME, "[*:%d,*:%d]") + call pargi (IM_LEN(im,1) / nc) + call pargi (IM_LEN(im,2) / nl) + } + + # Make a mask and compute the greyscale limits. + zpm = zsc_pmsection (Memc[section], im) + call mzscale (im, zpm, NULL, contrast, optimal_sample_size, z1, z2) + call imunmap (zpm) + call sfree (sp) +end + + +# MZSCALE -- Sample an image with pixel masks and compute greyscale limits. +# The image is sampled through a pixel mask. If no pixel mask is given +# a uniform sample mask is generated. If a bad pixel mask is given +# bad pixels in the sample are eliminated. Once the sample is obtained +# the greyscale limits are obtained using the ZSC_ZLIMITS algorithm. + +procedure mzscale (im, zpm, bpm, contrast, maxpix, z1, z2) + +pointer im #I image to be sampled +pointer zpm #I pixel mask for sampling +pointer bpm #I bad pixel mask +real contrast #I contrast parameter +int maxpix #I maximum number of pixels in sample +real z1, z2 #O output min and max greyscale values + +int i, ndim, nc, nl, npix, nbp, imstati() +pointer sp, section, v, sample, zmask, bp, zim, pmz, pmb, buf +pointer zsc_pmsection(), imgnlr() +bool pm_linenotempty() +errchk zsc_pmsection, zsc_zlimits + +begin + call smark (sp) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (v, IM_MAXDIM, TY_LONG) + call salloc (sample, maxpix, TY_REAL) + zmask = NULL + bp = NULL + + ndim = min (2, IM_NDIM(im)) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + # Generate a uniform sample mask if none is given. + if (zpm == NULL) { + switch (IM_NDIM(im)) { + case 1: + call sprintf (Memc[section], SZ_FNAME, "[*]") + default: + i = max (1., sqrt ((nc-1)*(nl-1) / real (maxpix))) + call sprintf (Memc[section], SZ_FNAME, "[*:%d,*:%d]") + call pargi (i) + call pargi (i) + } + zim = zsc_pmsection (Memc[section], im) + pmz = imstati (zim, IM_PMDES) + } else + pmz = imstati (zpm, IM_PMDES) + + # Set bad pixel mask. + if (bpm != NULL) + pmb = imstati (bpm, IM_PMDES) + else + pmb = NULL + + # Get the sample up to maxpix pixels. + npix = 0 + nbp = 0 + call amovkl (long(1), Memi[v], IM_MAXDIM) + repeat { + if (pm_linenotempty (pmz, Meml[v])) { + if (zmask == NULL) + call salloc (zmask, nc, TY_INT) + call pmglpi (pmz, Meml[v], Memi[zmask], 0, nc, 0) + if (pmb != NULL) { + if (pm_linenotempty (pmb, Meml[v])) { + if (bp == NULL) + call salloc (bp, nc, TY_INT) + call pmglpi (pmb, Meml[v], Memi[bp], 0, nc, 0) + nbp = nc + } else + nbp = 0 + + } + if (imgnlr (im, buf, Meml[v]) == EOF) + break + do i = 0, nc-1 { + if (Memi[zmask+i] == 0) + next + if (nbp > 0) + if (Memi[bp+i] != 0) + next + Memr[sample+npix] = Memr[buf+i] + npix = npix + 1 + if (npix == maxpix) + break + } + if (npix == maxpix) + break + } else { + do i = 2, ndim { + Meml[v+i-1] = Meml[v+i-1] + 1 + if (Meml[v+i-1] <= IM_LEN(im,i)) + break + else if (i < ndim) + Meml[v+i-1] = 1 + } + } + } until (Meml[v+ndim-1] > IM_LEN(im,ndim)) + + if (zpm == NULL) + call imunmap (zim) + + # Compute greyscale limits. + call zsc_zlimits (Memr[sample], npix, contrast, z1, z2) + + call sfree (sp) +end + + +# ZSC_PMSECTION -- Create a pixel mask from an image section. +# This only applies the mask to the first plane of the image. + +pointer procedure zsc_pmsection (section, refim) + +char section[ARB] #I Image section +pointer refim #I Reference image pointer + +int i, j, ip, ndim, temp, a[2], b[2], c[2], rop, ctoi() +pointer pm, im, mw, dummy, pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +define error_ 99 + +begin + # Decode the section string. + call amovki (1, a, 2) + call amovki (1, b, 2) + call amovki (1, c, 2) + ndim = min (2, IM_NDIM(refim)) + do i = 1, ndim + b[i] = IM_LEN(refim,i) + + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') { + ip = ip + 1 + + do i = 1, ndim { + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get a:b:c. Allow notation such as "-*:c" + # (or even "-:c") where the step is obviously negative. + + if (ctoi (section, ip, temp) > 0) { # a + a[i] = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b[i]) == 0) # a:b + goto error_ + } else + b[i] = a[i] + } else if (section[ip] == '-') { # -* + temp = a[i] + a[i] = b[i] + b[i] = temp + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + } else if (section[ip] == '*') # * + ip = ip + 1 + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, c[i]) == 0) + goto error_ + else if (c[i] == 0) + goto error_ + } + if (a[i] > b[i] && c[i] > 0) + c[i] = -c[i] + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (i < ndim) { + if (section[ip] != ',') + goto error_ + } else { + if (section[ip] != ']') + goto error_ + } + ip = ip + 1 + } + } + + # In this case make the values be increasing only. + do i = 1, ndim + if (c[i] < 0) { + temp = a[i] + a[i] = b[i] + b[i] = temp + c[i] = -c[i] + } + + # Make the mask. + pm = pm_newmask (refim, 16) + + rop = PIX_SET+PIX_VALUE(1) + if (c[1] == 1 && c[2] == 1) + call pm_box (pm, a[1], a[2], b[1], b[2], rop) + + else if (c[1] == 1) + for (i=a[2]; i<=b[2]; i=i+c[2]) + call pm_box (pm, a[1], i, b[1], i, rop) + + else + for (i=a[2]; i<=b[2]; i=i+c[2]) + for (j=a[1]; j<=b[1]; j=j+c[1]) + call pm_point (pm, j, i, rop) + + i = IM_NPHYSDIM(refim) + IM_NPHYSDIM(refim) = ndim + im = im_pmmapo (pm, refim) + IM_NPHYSDIM(refim) = i + dummy = imgl1i (im) # Force I/O to set header + ifnoerr (mw = mw_openim (refim)) { # Set WCS + call mw_saveim (mw, im) + call mw_close (mw) + } + + return (im) + +error_ + call error (1, "Error in image section specification") +end + + +.help zsc_zlimits +.nf ___________________________________________________________________________ +ZSC_ZLIMITS -- Compute limits for a linear transform that best samples the +the histogram about the median value. This is often called to compute +greyscale limits from a sample of pixel values. + +If the number of pixels is too small an error condition is returned. If +the contrast parameter value is zero the limits of the sample are +returned. Otherwise the sample is sorted and the median is found from the +central value(s). A straight line is fitted to the sorted sample with +interative rejection. If more than half the pixels are rejected the full +range is returned. The contrast parameter is used to adjust the transfer +slope about the median. The final limits are the extension of the fitted +line to the first and last array index. +.endhelp ______________________________________________________________________ + +define MIN_NPIXELS 5 # smallest permissible sample +define MAX_REJECT 0.5 # max frac. of pixels to be rejected +define GOOD_PIXEL 0 # use pixel in fit +define BAD_PIXEL 1 # ignore pixel in all computations +define REJECT_PIXEL 2 # reject pixel after a bit +define KREJ 2.5 # k-sigma pixel rejection factor +define MAX_ITERATIONS 5 # maximum number of fitline iterations + + +# ZSC_ZLIMITS -- Compute Z transform limits from a sample of pixels. + +procedure zsc_zlimits (sample, npix, contrast, z1, z2) + +real sample[ARB] #I Sample of pixel values (possibly resorted) +int npix #I Number of pixels +real contrast #I Contrast algorithm parameter +real z1, z2 #O Z transform limits + +int center_pixel, minpix, ngoodpix, ngrow, zsc_fit_line() +real zmin, zmax, median +real zstart, zslope + +begin + # Check for a sufficient sample. + if (npix < MIN_NPIXELS) + call error (1, "Insufficient sample pixels found") + + # If contrast is zero return the range. + if (contrast == 0.) { + call alimr (sample, npix, z1, z2) + return + } + + # Sort the sample, compute the range, and median pixel values. + # The median value is the average of the two central values if there + # are an even number of pixels in the sample. + + call asrtr (sample, sample, npix) + zmin = sample[1] + zmax = sample[npix] + + center_pixel = (npix + 1) / 2 + if (mod (npix, 2) == 1) + median = sample[center_pixel] + else + median = (sample[center_pixel] + sample[center_pixel+1]) / 2 + + # Fit a line to the sorted sample vector. If more than half of the + # pixels in the sample are rejected give up and return the full range. + # If the user-supplied contrast factor is not 1.0 adjust the scale + # accordingly and compute Z1 and Z2, the y intercepts at indices 1 and + # npix. + + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + ngrow = max (1, nint (npix * .01)) + ngoodpix = zsc_fit_line (sample, npix, zstart, zslope, + KREJ, ngrow, MAX_ITERATIONS) + + if (ngoodpix < minpix) { + z1 = zmin + z2 = zmax + } else { + if (contrast > 0) + zslope = zslope / contrast + z1 = max (zmin, median - (center_pixel - 1) * zslope) + z2 = min (zmax, median + (npix - center_pixel) * zslope) + } +end + + +# ZSC_FIT_LINE -- Fit a straight line to a data array of type real. This is +# an iterative fitting algorithm, wherein points further than ksigma from the +# current fit are excluded from the next fit. Convergence occurs when the +# next iteration does not decrease the number of pixels in the fit, or when +# there are no pixels left. The number of pixels left after pixel rejection +# is returned as the function value. + +int procedure zsc_fit_line (data, npix, zstart, zslope, krej, ngrow, maxiter) + +real data[npix] # data to be fitted +int npix # number of pixels before rejection +real zstart # Z-value of pixel data[1] (output) +real zslope # dz/pixel (output) +real krej # k-sigma pixel rejection factor +int ngrow # number of pixels of growing +int maxiter # max iterations + +int i, ngoodpix, last_ngoodpix, minpix, niter +real xscale, z0, dz, x, z, mean, sigma, threshold +double sumxsqr, sumxz, sumz, sumx, rowrat +pointer sp, flat, badpix, normx +int zsc_reject_pixels(), zsc_compute_sigma() + +begin + call smark (sp) + + if (npix <= 0) + return (0) + else if (npix == 1) { + zstart = data[1] + zslope = 0.0 + return (1) + } else + xscale = 2.0 / (npix - 1) + + # Allocate a buffer for data minus fitted curve, another for the + # normalized X values, and another to flag rejected pixels. + + call salloc (flat, npix, TY_REAL) + call salloc (normx, npix, TY_REAL) + call salloc (badpix, npix, TY_SHORT) + call aclrs (Mems[badpix], npix) + + # Compute normalized X vector. The data X values [1:npix] are + # normalized to the range [-1:1]. This diagonalizes the lsq matrix + # and reduces its condition number. + + do i = 0, npix - 1 + Memr[normx+i] = i * xscale - 1.0 + + # Fit a line with no pixel rejection. Accumulate the elements of the + # matrix and data vector. The matrix M is diagonal with + # M[1,1] = sum x**2 and M[2,2] = ngoodpix. The data vector is + # DV[1] = sum (data[i] * x[i]) and DV[2] = sum (data[i]). + + sumxsqr = 0 + sumxz = 0 + sumx = 0 + sumz = 0 + + do i = 1, npix { + x = Memr[normx+i-1] + z = data[i] + sumxsqr = sumxsqr + (x ** 2) + sumxz = sumxz + z * x + sumz = sumz + z + } + + # Solve for the coefficients of the fitted line. + z0 = sumz / npix + dz = sumxz / sumxsqr + + # Iterate, fitting a new line in each iteration. Compute the flattened + # data vector and the sigma of the flat vector. Compute the lower and + # upper k-sigma pixel rejection thresholds. Run down the flat array + # and detect pixels to be rejected from the fit. Reject pixels from + # the fit by subtracting their contributions from the matrix sums and + # marking the pixel as rejected. + + ngoodpix = npix + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + + for (niter=1; niter <= maxiter; niter=niter+1) { + last_ngoodpix = ngoodpix + + # Subtract the fitted line from the data array. + call zsc_flatten_data (data, Memr[flat], Memr[normx], npix, z0, dz) + + # Compute the k-sigma rejection threshold. In principle this + # could be more efficiently computed using the matrix sums + # accumulated when the line was fitted, but there are problems with + # numerical stability with that approach. + + ngoodpix = zsc_compute_sigma (Memr[flat], Mems[badpix], npix, + mean, sigma) + threshold = sigma * krej + + # Detect and reject pixels further than ksigma from the fitted + # line. + ngoodpix = zsc_reject_pixels (data, Memr[flat], Memr[normx], + Mems[badpix], npix, sumxsqr, sumxz, sumx, sumz, threshold, + ngrow) + + # Solve for the coefficients of the fitted line. Note that after + # pixel rejection the sum of the X values need no longer be zero. + + if (ngoodpix > 0) { + rowrat = sumx / sumxsqr + z0 = (sumz - rowrat * sumxz) / (ngoodpix - rowrat * sumx) + dz = (sumxz - z0 * sumx) / sumxsqr + } + + if (ngoodpix >= last_ngoodpix || ngoodpix < minpix) + break + } + + # Transform the line coefficients back to the X range [1:npix]. + zstart = z0 - dz + zslope = dz * xscale + + call sfree (sp) + return (ngoodpix) +end + + +# ZSC_FLATTEN_DATA -- Compute and subtract the fitted line from the data array, +# returned the flattened data in FLAT. + +procedure zsc_flatten_data (data, flat, x, npix, z0, dz) + +real data[npix] # raw data array +real flat[npix] # flattened data (output) +real x[npix] # x value of each pixel +int npix # number of pixels +real z0, dz # z-intercept, dz/dx of fitted line +int i + +begin + do i = 1, npix + flat[i] = data[i] - (x[i] * dz + z0) +end + + +# ZSC_COMPUTE_SIGMA -- Compute the root mean square deviation from the +# mean of a flattened array. Ignore rejected pixels. + +int procedure zsc_compute_sigma (a, badpix, npix, mean, sigma) + +real a[npix] # flattened data array +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +real mean, sigma # (output) + +real pixval +int i, ngoodpix +double sum, sumsq, temp + +begin + sum = 0 + sumsq = 0 + ngoodpix = 0 + + # Accumulate sum and sum of squares. + do i = 1, npix + if (badpix[i] == GOOD_PIXEL) { + pixval = a[i] + ngoodpix = ngoodpix + 1 + sum = sum + pixval + sumsq = sumsq + pixval ** 2 + } + + # Compute mean and sigma. + switch (ngoodpix) { + case 0: + mean = INDEF + sigma = INDEF + case 1: + mean = sum + sigma = INDEF + default: + mean = sum / ngoodpix + temp = sumsq / (ngoodpix - 1) - sum**2 / (ngoodpix * (ngoodpix - 1)) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngoodpix) +end + + +# ZSC_REJECT_PIXELS -- Detect and reject pixels more than "threshold" greyscale +# units from the fitted line. The residuals about the fitted line are given +# by the "flat" array, while the raw data is in "data". Each time a pixel +# is rejected subtract its contributions from the matrix sums and flag the +# pixel as rejected. When a pixel is rejected reject its neighbors out to +# a specified radius as well. This speeds up convergence considerably and +# produces a more stringent rejection criteria which takes advantage of the +# fact that bad pixels tend to be clumped. The number of pixels left in the +# fit is returned as the function value. + +int procedure zsc_reject_pixels (data, flat, normx, badpix, npix, + sumxsqr, sumxz, sumx, sumz, threshold, ngrow) + +real data[npix] # raw data array +real flat[npix] # flattened data array +real normx[npix] # normalized x values of pixels +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +double sumxsqr,sumxz,sumx,sumz # matrix sums +real threshold # threshold for pixel rejection +int ngrow # number of pixels of growing + +int ngoodpix, i, j +real residual, lcut, hcut +double x, z + +begin + ngoodpix = npix + lcut = -threshold + hcut = threshold + + do i = 1, npix + if (badpix[i] == BAD_PIXEL) + ngoodpix = ngoodpix - 1 + else { + residual = flat[i] + if (residual < lcut || residual > hcut) { + # Reject the pixel and its neighbors out to the growing + # radius. We must be careful how we do this to avoid + # directional effects. Do not turn off thresholding on + # pixels in the forward direction; mark them for rejection + # but do not reject until they have been thresholded. + # If this is not done growing will not be symmetric. + + do j = max(1,i-ngrow), min(npix,i+ngrow) { + if (badpix[j] != BAD_PIXEL) { + if (j <= i) { + x = normx[j] + z = data[j] + sumxsqr = sumxsqr - (x ** 2) + sumxz = sumxz - z * x + sumx = sumx - x + sumz = sumz - z + badpix[j] = BAD_PIXEL + ngoodpix = ngoodpix - 1 + } else + badpix[j] = REJECT_PIXEL + } + } + } + } + + return (ngoodpix) +end diff --git a/pkg/images/tv/display/zsttim.x b/pkg/images/tv/display/zsttim.x new file mode 100644 index 00000000..dc6c91f6 --- /dev/null +++ b/pkg/images/tv/display/zsttim.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# ZSTTIM -- Return status on binary file display device. + +procedure zsttim (chan, what, lvalue) + +int chan[ARB], what +long lvalue + +include "iis.com" + +begin + call zsttgd (iischan, what, lvalue) + + if (what == FSTT_MAXBUFSIZE) { + # Return the maximum transfer size in bytes. + if (lvalue == 0) + lvalue = FSTT_MAXBUFSIZE + if (!packit) + lvalue = min (IIS_MAXBUFSIZE, lvalue) * 2 + } +end diff --git a/pkg/images/tv/display/zwndim.x b/pkg/images/tv/display/zwndim.x new file mode 100644 index 00000000..d27027cf --- /dev/null +++ b/pkg/images/tv/display/zwndim.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "zdisplay.h" + +# ZWNDIM -- Window binary file display device. + +procedure zwndim (chan) + +int chan[ARB] +int device + +begin + device = chan[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iiswnd3 (chan, chan, chan) + } +end + +procedure zwndim3 (chan1, chan2, chan3) + +int chan1[ARB], chan2[ARB], chan3[ARB] +int device + +begin + device = chan1[1] / DEVCODE + switch (device) { + case IIS_CHAN: + call iiswnd3 (chan1, chan2, chan3) + } +end diff --git a/pkg/images/tv/display/zzdebug.x b/pkg/images/tv/display/zzdebug.x new file mode 100644 index 00000000..eb642d42 --- /dev/null +++ b/pkg/images/tv/display/zzdebug.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +task mktest = t_mktest, + sigl2 = t_sigl2, + wrimage = t_wrimage, + zscale = t_zscale, + rcur = t_rcur + +define TWOPI 6.23 + + +# MKTEST -- Make a test image containing a circularly symetric sinusoid. + +procedure t_mktest() + +char imname[SZ_FNAME] +int nx, ny +int i, j +real period, xcen, ycen, radius +pointer im, line + +int clgeti() +real clgetr() +pointer immap(), impl2r() + +begin + call clgstr ("imname", imname, SZ_FNAME) + im = immap (imname, NEW_IMAGE, 0) + + nx = clgeti ("nx") + ny = clgeti ("ny") + period = clgetr ("period") + + IM_LEN(im,1) = nx + IM_LEN(im,2) = ny + + xcen = (nx + 1) / 2.0 + ycen = (ny + 1) / 2.0 + + do j = 1, ny { + line = impl2r (im, j) + do i = 1, nx { + radius = sqrt ((i - xcen) ** 2 + (j - ycen) ** 2) + Memr[line+i-1] = sin ((radius / period) * TWOPI) * 255.0 + } + } + + call imunmap (im) +end + + +# READ -- Benchmark scaled input procedure. + +procedure t_sigl2 () + +char imname[SZ_FNAME] +pointer im, si, buf +int i, nx, ny, xblk, yblk +pointer sigl2_setup(), sigl2s(), immap() + +begin + call clgstr ("imname", imname, SZ_FNAME) + im = immap (imname, READ_ONLY, 0) + + nx = IM_LEN(im,1) + ny = IM_LEN(im,2) + + xblk = INDEFI + yblk = INDEFI + si = sigl2_setup (im, 1.0,real(nx),nx,xblk, 1.0,real(ny),ny,yblk,0) + + do i = 1, ny + buf = sigl2s (si, i) + + call sigl2_free (si) + call imunmap (im) +end + + +# WRIMAGE -- Benchmark image output as used in the display program. + +procedure t_wrimage () + +char imname[SZ_FNAME] +int i, ncols, nlines +pointer im, buf +int clgeti() +pointer immap(), imps2s() + +begin + call clgstr ("imname", imname, SZ_FNAME) + im = immap (imname, NEW_IMAGE, 0) + + ncols = clgeti ("ncols") + nlines = clgeti ("nlines") + + IM_LEN(im,1) = ncols + IM_LEN(im,2) = nlines + IM_PIXTYPE(im) = TY_SHORT + + do i = 1, nlines + buf = imps2s (im, 1, ncols, i, i) + + call imunmap (im) +end + + +# ZSCALE -- Test the zscale procedure, used to determine the smallest range of +# greyscale values which preserves the most information in an image. + +procedure t_zscale() + +char imname[SZ_FNAME] +int sample_size, len_stdline +real z1, z2, contrast +int clgeti() +real clgetr() +pointer im, immap() + +begin + call clgstr ("imname", imname, SZ_FNAME) + im = immap (imname, READ_ONLY, 0) + + sample_size = clgeti ("npix") + len_stdline = clgeti ("stdline") + contrast = clgetr ("contrast") + + call zscale (im, z1, z2, contrast, sample_size, len_stdline) + call printf ("z1=%g, z2=%g\n") + call pargr (z1) + call pargr (z2) +end + + +# RCUR -- Try reading the image cursor. + +procedure t_rcur() + +real x, y +int wcs, key +int wci, pause +char device[SZ_FNAME] +char strval[SZ_LINE] + +bool clgetb() +int btoi(), clgeti(), imdrcur() + +begin + call clgstr ("device", device, SZ_FNAME) + wci = clgeti ("wcs") + pause = btoi (clgetb ("pause")) + + while (imdrcur (device, x,y,wcs,key,strval,SZ_LINE, wci,pause) != EOF) { + call printf ("%8.2f %8.2f %d %o %s\n") + call pargr (x) + call pargr (y) + call pargi (wcs) + call pargi (key) + call pargstr (strval) + if (key == 'q') + break + } +end diff --git a/pkg/images/tv/doc/Tv.hlp b/pkg/images/tv/doc/Tv.hlp new file mode 100644 index 00000000..c48bbe2e --- /dev/null +++ b/pkg/images/tv/doc/Tv.hlp @@ -0,0 +1,357 @@ +.helpsys dcontrol Feb84 "Image Display Control" +.ce +\fBImage Display Control Software\fR +.ce +Technical Specifications +.ce +February 17, 1984 + + +.nh +Virtual Display Characteristics + + The display device is assumed to have N image memories or frames, +where N is at least one. All frames are assumed to be the same size and depth. +The frame size and depth (number of bits per pixel) are constant for a device. +There should be at least one graphics frame. The virtual interface associates +one graphics frame with each image frame, but at the device level the graphics +may be or-ed together and displayed on a single plane, if necessary. +A lookup table is associated with each image frame buffer and with each +color gun. The input of a color gun is the sum of the outputs of zero +or more frame buffers. There must be at least one cursor. + +.nh 2 +Basic Functions + + The virtual display device is assumed to provide the following +minimal set of basic functions. +.ls 4 +.ls [1] +Read or write an image frame buffer. Random addressability of pixels +is not assumed; writes may be aligned on image lines if necessary. +The ability to write more than one image line in a single transfer is assumed. +.le +.ls [2] +Erase an entire image frame buffer. +.le +.ls [3] +Read or write an image frame lookup table. +.le +.ls [4] +Read or write the pseudocolor lookup table. +.le +.ls [5] +Connect the output of one or more image frame lookup tables to a +color gun (used to select the frame to be displayed, etc.). +.le +.ls [6] +Read or write the position of a cursor. +.le +.ls [7] +Read, write, or "or into" a graphics overlay bit plane. A one bit +graphics plane is associated with each image frame. Graphics planes +may be erased and turned on and off independently of each other and +the image planes. A read or write operation may reference any combination +of graphics planes simultaneously, permitting multicolor vector graphics. +A single lookup table is used to assign a color to each graphics plane. +.le +.le + + +The following functions are supported but are not required. +.ls +.ls [8] +Zoom and pan. +.le +.ls [9] +Split screen: simultaneous display of any two frames, horizontal or vertical +split through the center of the display. +.le +.le + + +Blinking of two or more image frames is provided in software. Character and +vector generation in the graphics overlays is only provided in software in the +current interface. + +.nh 2 +Lookup Tables + + A monochrome lookup table is associated with each image frame and with +each of the three color guns (red, green, and blue). A lookup table may be +read and written independently of any other lookup table or image frame. +The image frame lookup tables are used principally for window stretch +enhancement (contrast and dc offset), and the color lookup tables are used +for pseudocolor. + +Our model assumes that the input of each color gun may be connected to the +sum of the lookup table outputs of zero or more image frames. Furthermore, +each color gun assignment may be specified independently of that for any +other color gun. The more common display modes are shown below. The table +illustrates the assignment of image frames to color guns. If only one image +frame combination appears in the list, that one combination is taken to be +assigned to each gun. Thus, "RGB = 123" indicates that the \fIsum\fR of the +outputs of frames 1, 2, and 3 is assigned to \fIeach\fR of the three color guns. + +.nf + RGB = 1 single frame monochrome, pseudocolor, etc. + RGB = 1,2,3 true color (R=1, G=2, B=3) + RGB = 123 multi frame monochrome, pseudocolor, etc. +.fi + +On many displays, there will be restrictions on the ways in which frames +may be assigned to guns. For example, many displays will not permit a gun +to be assigned to more than one frame. + +Our model also associates a single monochrome lookup table with each of +the three color guns. By feeding the same input into each of the guns, +but loading a different lookup table into each gun, many types of +pseudocolor enhancement are possible. If monochrome enhancement or +true color is desired, the color lookup tables are normally all set to +provide a one to one mapping, effectively taking them out of the circuit. + +.nh 2 +Cursors + + Each image display device is assumed to have at least one cursor, +with the following associated control functions: +.ls 4 +.ls [1] +Read cursor position. The one-indexed coordinates of the center of the +visible cursor are returned. The origin is assumed to be consistent +with that used for reading and writing image data, but is otherwise +undefined. A read should return immediately (sample mode), rather than +wait for some external event to occur (event mode). +.le +.ls [2] +Write cursor position. A read followed by a write does not move the +cursor. Cursor motions do not affect image data in any way. +.le +.ls [3] +Disable cursor (invisible cursor). +.le +.ls [4] +Enable cursor. +.le +.ls [5] +Blink cursor. +.le +.le + +.nh +Display Control Software + + A single executable process contains all display control functions. +A separate process (executable image) is provided for each display device. +All display control processes behave identically at the CL level. The STDIMAGE +environment variable is used to select the particular display control process +to be run. + + +.ks +.nf + user interface + display control process + virtual device interface + physical device +.fi + +.ce +Structure of the Display Control Software +.ke + + +The display control process consists of a device independent part and a +device dependent part. The device dependent part provides the virtual +device control and data functions identified in section 1. +The specifications of the virtual device interface have not yet been written, +though a prototype interface has been implemented for the IIS model 70. +In the long run, the virtual device interface may be provided by an +extension to GKS (the Graphical Kernel System). + +.nh 2 +User Interfaces + + At least two user interfaces are planned for display control. The first, +and most transportable, interface will be a conventional CL level command +interface. Separate commands will be provided for frame selection, +enhancement selection, frame erase, windowing, blinking, etc. The second +interface will be a menu driven interface run on a dedicated terminal +with touch screen overlay for input. This latter interface will run +asynchronously with the user terminal, and will therefore provide access +to the display at all times, as well as increased functionality and +interactiveness. Both user interfaces will use the same virtual device +interface. + +.nh 3 +The Display Control Package + + The command oriented image display control interface will be implemented +as a set of CL callable tasks in the package \fBimages.dcontrol\fR. +The new \fBdcontrol\fR package will include the \fBdisplay\fR program, +used to load images into the image display device, and any other programs +specifically concerned with the image display device. +The specifications for the package are given below (excluding the \fBdisplay\fR +program, which is documented elsewhere). All control functions operate +independently of each other, i.e., without side effects, unless otherwise noted. + + +.ks +.nf + blink dsave initdisplay rgb + contour frame lumatch splitscreen + display grclear monochrome window + drestore imclear pseudocolor zoom +.fi + +.ce +The \fBDcontrol\fR Package +.ke + + +The basic \fBdcontrol\fR package is shown above, and further documentation +is given below. Additional routines will be added in the future. +These will include: +.ls +.ls [1] +An display routine wherein the image histogram is computed and plotted, +then the user interactively marks the intensity region to be mapped into +the display, using the graphics cursor. +.le +.ls [2] +A routine for reading out a monochrome display into an imagefile, +which is then plotted on a hardcopy device (i.e., the Dicomed). +.le +.ls [3] +A routine for drawing vectors, marks, and text strings into a graphics +overlay. +.le +.le + +The display status should not be modified upon entry to the package, i.e., +the display should not change except under control of the user. +For example, if a new user logs on and a previous user's image is still +loaded and being displayed in pseudocolor, the control software should not +suddenly change the display mode to RGB, merely because the new user left +the display in RGB mode when they last logged off. The physical display +device is the important reference frame. +[N.B.: See also \fBdsave\fR and \fBdrestore\fR]. + +.ls +.ls \fBblink\fR (frame1, frame2 [, ... frameN] [, rate=1]) +The indicated frames are blinked at a rate given by the hidden parameter +\fIrate\fR. The positional arguments are the frame numbers; +a variable number of arguments are permitted. The order of the arguments +determines the order in which the frames are displayed. The same frame +may appear any number of times in the list, permitting different frames +to be displayed for various lengths of time. +.le +.ls \fBcontour\fR ([frame]) +The operation of this routine is very similar to that of \fBwindow\fR. +A cursor device is interactively used to control the spacing and width +of black contour lines, written with equal spacing into the image +lookup table. The window transfer function is not changed, other than +to black out the regions where the contour bands fall. Since only the +image frame lookup table is affected, this routine may be used with any +form of enhancement (i.e., pseudocolor). +.le +.ls \fBdsave\fR (save_file [, image=1234, graphics=1234]) +The full control status of the display, and optionally the image and +graphics memories, are saved in the named savefile for later restoration by +\fBdrestore\fR. By default all image and graphics memories are saved; +the hidden parameters \fBimage\fR and \fBgraphics\fR may be used to +indicate the specific image frames or graphics planes to be saved, +if desired. +.le +.ls \fBdrestore\fR (savefile) +The display device is restored to a previously saved state from the named +savefile. +.le +.ls \fBframe\fR (frame_number) +Select single frame mode and display the indicated frame. Frame enhancement +is not affected. This command will clear any multiple frame modes +(rgb, blink, split screen, etc.) previously in effect. +.le +.ls \fBgrclear\fR (frame) +The specified graphics frame is cleared. If the frame number is zero, +all graphics frames are cleared. +.le +.ls \fBimclear\fR (frame) +The specified image frame is cleared. If the frame number is zero, +all image frames are cleared. +.le +.ls \fBinitdisplay\fR +Initializes the image display to a default (device dependent) state. +All image and graphics memories are cleared, all lookup tables are +set to a default mapping (usually one-to-one), the cursor is centered +and enabled, single frame monochrome enhancement is selected, zoom, +blink, etc. are disabled, and frame one is selected for display. +.le +.ls \fBmonochrome\fR +Select monochrome enhancement (black and white). +.le +.ls \fBlumatch\fR (frame, reference_frame) +The image frame lookup table of the first frame is matched to that of +the reference frame. +.le +.ls \fBpseudocolor\fR (type_of_pseudocolor [, ncolors=64]) +Select one of the many possible pseudocolor enhancement modes. A single +string type argument selects the type of enhancement to be displayed. +The hidden parameter \fBncolors\fR controls the maximum number of +colors to be displayed; permissible values are limited to powers of +two. Pseudocolor is a contrast enhancement technique, and is most useful for +smooth images. The types of pseudocolor enhancement currently implemented +are the following: +.ls +.ls linear +The full range of greylevels are uniformly mapped into a spectrum of colors +ranging from blue through red. +.le +.ls random +A randomly selected color is assigned to each output greylevel. +This mode provides maximum discrimination between successive greylevels. +.le +.le +.sp +Selecting a pseudocolor or monochrome enhancement mode does not change the +windowing. After selecting an enhancement mode, \fBwindow\fR may be used +to control the number and range of color or grey levels in the image. +The number of greylevels or colors actually displayed will depend on the +smoothness of the input frames, and on how the input frames are windowed. +.le +.ls \fBrgb\fR [red=1, green=2, blue=3] +True color mode is selected, i.e., the specified red frames are mapped +to the red gun, the green frames are mapped to the green gun, and so on. +The hidden parameters \fIred\fR, \fIgreen\fR, and \fIblue\fR define +the mapping of image frames to guns. On some displays, it may be possible +to additively assign more than one frame to a single gun, i.e., "red=123" +would assign the sum of frames 1 through 3 to the red gun. +If pseudocolor enhancement was previously in effect it may or may not +be cleared, depending on the display characteristics. +.le +.ls \fBsplitscreen\fR (frame, frame [, vertical=yes]) +Two images are displayed simultaneously, one on either half of the image. +The two images may be split either horizontally or vertically. +.le +.ls \fBwindow\fR [frame] [, ...frame] +This command causes a linear mapping function to be repetitively loaded +into the lookup table for one or more image frames. If no frame +arguments are given, the frame or frames currently displayed are windowed. +In RGB mode, for example, all frames are simultaneously windowed by +default. The \fBhjklHJKL\fR keys on the terminal, the trackball, +or some other analog input device associated with the display, may be used +to interactively adjust the mapping. As the mapping is changed, the cursor +will be seen to move on the display. Vertical motions control the contrast +and whether or not a positive or negative image is displayed; the highest +contrast lies furthest from the center. Horizontal motions adjust the dc +offset. [N.B.: Initialize the cursor position to reflect the current mapping +before entering the loop, to avoid any abrupt changes in the windowing.] +.le +.ls \fBzoom\fR (scale_factor) +The current display is magnified by the indicated scale factor, which +is normally limited to small powers of two (i.e., 1, 2, 4, and 8). +While in zoom mode, the cursor controls the position of the viewport window +on the full image. +.le +.le +.endhelp diff --git a/pkg/images/tv/doc/bpmedit.hlp b/pkg/images/tv/doc/bpmedit.hlp new file mode 100644 index 00000000..2350b846 --- /dev/null +++ b/pkg/images/tv/doc/bpmedit.hlp @@ -0,0 +1,155 @@ +.help bpmedit Aug07 images.tv +.ih +NAME +bpmedit -- examine and edit bad pixel masks associated with images +.ih +USAGE +bpmedit images +.ih +PARAMETERS +.ls images +List of images whose bad pixel masks are to be edit. The images must +contain the keyword BPM whose value is an existing bad pixel mask to +be edit. If the keyword is missing or the mask does not exit a warning +is issued and the task proceeds to the next image. +.le +.ls bpmkey = "BPM" +The mask to be edited is defined by the value of this keyword. +.le +.ls frame = 1 +The display frame where the image with the mask overlay is shown. +.le +.ls refframe = 2 +The display frame with the image without the mask is shown. +.le +.ls command = "display ..." +Command for displaying and updating the mask overlay. This is the +command used with \fBimedit\fR. This should be changed with care. +In the string the following changes are made: + +.nf + $image -- substitute the image + $mask -- substitute the mask being edited + $frame -- substitute the value of the frame parameter + $erase -- substituted by imedit +.fi +.le + +.ls display = yes +Use the task interactively with the display? This sets the behavior +of \fBimedit\fR as described for the parameter of the same name. +.le +.ls cursor = "" +Image cursor input. This is normally either a null string for interactive +display editing or the value of a file with cursor commands to edit +non-interactively. See the help for \fBimedit\fR for more information. +.le + +.ih +ADDITIONAL PARAMETERS + +This task calls \fBdisplay\fR to load the image display and \fBimedit\fR +to do the editing. The current default parameters are used from those +tasks except the image names, frames, and the display command are set by +this task. Also the search radius is set to zero (i.e. no centering). +Also the \fIdisplay\fR and \fIcursor\fR parameters override the +values of the parameters of the same name in \fBimedit\fR. Of particular +note is the default value for imedit.value which defines the mask value to +be set initially. This value may be changed interactively in \fBimedit\fR. +.ih +DESCRIPTION +\fBBpmedit\fR is a variant of \fBimedit\fR. It displays the input images +with the masks overlaid. The mask is defined +by the value of the keyword keywords specified by the \fIbpmkey\fR +parameter. The editing commands apply to the mask overlay and not the +image pixels. In this application the edited values should be integer mask +values. In the usual case where zero indicates good pixels and non-zero +indicates bad pixels one can set and unset values by changing current +replacement value with ":value". Two useful parameters, ":minvalue" +and ":maxvalue", are useful in this context to allow editing only +specific ranges of mask values. Note that many of the imedit options are +not useful for mask editing. The '?' keystroke prints a list of the +useful cursor and colon commands. This list is also shown below. + +Because it is common to want to see the image pixels to which the +mask values apply this task loads two image display frames. In one the +mask is overlaid and changes to the mask are updated with the +redisplay options of imedit (note the options to turn on and off +automatic redisplay). In the second the image without the mask is +displayed. The editing commands may be given in either frame but the +mask updates will appear only in the mask overlay frame. + +This task also provides the parameters \fIdisplay\fR and \fIcursor\fR +to use \fBimedit\fR in a non-interactive manner as described for that +task. Because only the setting and clearing of rectangles, circles, +or vectors makes sense with this task this may not be of great use. +Also there are many other tasks that can be used to edit masks +non-interactively. + +Please read the help for \fBimedit\fR for details of the editing +process. + +.nf + BPMEDIT CURSOR KEYSTROKE COMMANDS + + The following are the useful commands for BPMEDIT. Note all + the commands for IMEDIT are available but only those shown + here should be used for editing pixel masks. + + ? Print help + : Colon commands (see below) + i Initialize (start over without saving changes) + q Quit and save changes + r Redraw image display + + Increase radius by one + - Decrease radius by one + I Interrupt task immediately + Q Quit without saving changes + + The following editing options are available. Rectangular + and vector regions are specified with two positions and + aperture regions are specified by one position. The current + aperture type (circular or square) is used in the latter + case. All the following substitute the new value set for + the "value" parameter (see :value). Some replace all pixels + within the mask that have the same pixel value as the value + at the cursor position. + + d Set rectangle to "value" + e Set aperture to "value" + u Undo last change (see also 'i', 'j', and 'k') + v Set vector to "value" + = Replace pixels = to "cursor value" to "value" + < Replace pixels < or = to "cursor value" to "value" + > Replace pixels > than or = to "cursor value" to "value" + + + BPMEDIT COLON COMMANDS + + The colon either print the current value of a parameter when + there is no value or set the parameter to the specified + value. + + aperture [type] Aperture type (circular|square) + autodisplay [yes|no] Automatic image display? + command [string] Display command + display [yes|no] Display image? + eparam Edit parameters + radius [value] Aperture radius + value [value] Constant substitution value + minvalue [value] Minimum value for modification (INDEF=minimum) + maxvalue [value] Maximum value for modification (INDEF=maximum) + write [name] Write changes to name +.fi +.ih +EXAMPLES +1. Interactively edit a mask. + +.nf + cl> bpmedit wpix +.fi + +.ih +SEE ALSO +imedit, display, badpiximage, text2mask, mskexpr, mskregions, imexpr +.endhelp diff --git a/pkg/images/tv/doc/display.hlp b/pkg/images/tv/doc/display.hlp new file mode 100644 index 00000000..9e8670c4 --- /dev/null +++ b/pkg/images/tv/doc/display.hlp @@ -0,0 +1,555 @@ +.help display Mar97 images.tv +.ih +NAME +display -- Load and display images in an image display +.ih +USAGE +display image frame +.ih +PARAMETERS +.ls image +Image to be loaded. +.le +.ls frame +Display frame to be loaded. +.le + +.ls bpmask = "BPM" +Bad pixel mask. The bad pixel mask is used to exclude bad pixels from the +automatic intensity mapping algorithm. It may also be displayed as an +overlay or to interpolate the input image as selected by the \fIbpdisplay\fR +parameter. The bad pixel mask is specified by a pixel list image +(.pl extension) or an regular image. Values greater than zero define the +bad pixels. The special value "BPM" may be specified to select a pixel list +image defined in the image header under the keyword "BPM". If the +bad pixel mask cannot be found a warning is given and the bad pixel mask +is not used in the display. +.le +.ls bpdisplay = "none" (none|overlay|interpolate) +Type of display for the bad pixel mask. The options are "none" to not +display the mask, "overlay" to display as an overlay with the colors given +by the \fIbpcolors\fR parameter, or "interpolate" to linearly interpolate +across the bad pixels in the displayed image. Note that the bad is still +used in the automatic intensity scaling regardless of the type of display +for the bad pixel mask. +.le +.ls bpcolors = "red" +The mapping between bad pixel values and display colors or intensity values +when the bad pixels are displayed as an overlay. There are two forms, +explicit color assignments for values or ranges of values, and expressions. +These is described in the OVERLAY COLOR section. +.le + +.ls overlay = "" +Overlay mask to be displayed. The overlay mask may be a pixel list image +(.pl extension) or a regular image. Overlay pixels are identified by +values greater than zero. The overlay values are displayed with a mapping +given by the \fIocolors\fR parameter. If the overlay cannot be found a +warning is given and the overlay is not displayed. +.le +.ls ocolors = "green" +The mapping between bad pixel values and display colors or intensity values +when the bad pixels are displayed as an overlay. There are two forms, +explicit color assignments for values or ranges of values, and expressions. +These is described in the OVERLAY COLOR section. +.le + +.ls erase = yes +Erase frame before loading image? +.le +.ls border_erase = no +Erase unfilled area of window in display frame if the whole frame is not +erased? +.le +.ls select_frame = yes +Select the display frame to be the same as the frame being loaded? +.le +.ls repeat = no +Repeat the previous spatial and intensity transformations? +.le +.ls fill = no +Interpolate the image to fit the display window? +.le +.ls zscale = yes +Apply an automatic intensity mapping algorithm when loading the image? +.le +.ls contrast = 0.25 +Contrast factor for the automatic intensity mapping algorithm. +If a value of zero is given then the minimum and maximum of the +intensity sample is used. +.le +.ls zrange = yes +If not using the automatic mapping algorithm (\fIzscale = no\fR) map the +full range of the image intensity to the full range of the display? If the +displayed image has current min/max values defined these will be used to +determine the mapping, otherwise the min/max of the intensity sample will +be used. The \fIMINMAX\fR task can be used to update the min/max values in +the image header. +.le +.ls zmask = "" +Pixel mask selecting the sample pixels for the automatic or range intensity +mapping algorithm. The pixel mask may be a pixel list image (.pl +extension), a regular image, or an image section. The sample pixels are +identified by values greater than zero in the masks and by the region specified +in an image section. If no mask specification is given then a uniform sample +of approximately \fInsample\fR good pixels will be used. The \fInsample\fR +parameter also limits the number of sample pixels used from a mask. Note that +pixels identified by the bad pixel mask will be excluded from the sample. +.le +.ls nsample = 1000 (minimum of 100) +The number of pixels from the image sampled for computing the automatic +intensity scaling. This number will be uniformly sampled from the image +if the default \fIzmask\fR is used otherwise the first \fInsample\fR +pixels from the specified mask will be used. +.le +.ls xcenter = 0.5, ycenter = 0.5 +Horizontal and vertical centers of the display window in normalized +coordinates measured from the left and bottom respectively. +.le +.ls xsize = 1, ysize = 1 +Horizontal and vertical sizes of the display window in normalized coordinates. +.le +.ls xmag = 1., ymag = 1. +Horizontal and vertical image magnifications when not filling the display +window. Magnifications greater than 1 map image pixels into more than 1 +display pixel and magnifications less than 1 map more than 1 image pixel +into a display pixel. +.le +.ls order = 0 +Order of the interpolator to be used for spatially interpolating the image. +The current choices are 0 for pixel replication, and 1 for bilinear +interpolation. +.le +.ls z1, z2 +Minimum and maximum image intensity to be mapped to the minimum and maximum +display levels. These values apply when not using the automatic or range +intensity mapping methods. +.le +.ls ztrans = "linear" +Transformation of the image intensity levels to the display levels. The +choices are: +.ls "linear" +Map the minimum and maximum image intensities linearly to the minimum and +maximum display levels. +.le +.ls "log" +Map the minimum and maximum image intensities linearly to the range 1 to 1000, +take the logarithm (base 10), and then map the logarithms to the display +range. +.le +.ls "none" +Apply no mapping of the image intensities (regardless of the values of +\fIzcale, zrange, z1, and z2\fR). For most image displays, values exceeding +the maximum display value are truncated by masking the highest bits. +This corresponds to applying a modulus operation to the intensity values +and produces "wrap-around" in the display levels. +.le +.ls "user" +User supplies a look up table of intensities and their corresponding +greyscale values. +.le +.le +.ls lutfile = "" +Name of text file containing the look up table when \fIztrans\fR = user. +The table should contain two columns per line; column 1 contains the +intensity, column 2 the desired greyscale output. +.le +.ih +DESCRIPTION +The specified image and overlay mask are loaded into the specified frame of +the standard image display device ("stdimage"). For devices with more than +one frame it is possible to load an image in a frame different than that +displayed on the monitor. An option allows the loaded frame to become the +displayed frame. The previous contents of the frame may be erased (which +can be done very quickly on most display devices) before the image is +loaded. Without erasing, the image replaces only those pixels in the frame +defined by the display window and spatial mapping described below. This +allows displaying more than one image in a frame. An alternate erase +option erases only those pixels in the defined display window which are not +occupied by the image being loaded. This is generally slower than erasing +the entire frame and should be used only if a display window is smaller +than the entire frame. + +The image is mapped both in intensity and in space. The intensity is +mapped from the image pixel values to the range of display values in the +device. Spatial interpolation maps the image pixel coordinates into a part +of the display frame called the display window. Many of the parameters of +this task are related to these two transformations. + +A bad pixel mask may be specified to be displayed as an overlay or to +interpolate the displayed image. It is also used to exclude bad pixels +from the automatic intensity scaling. The bad pixel mask is specified by +the parameter \fIbpmask\fR and the display mode by the \fIbpdisplay\fR +parameter. The overlay display option uses the \fIbpcolors\fR parameters +to specify a color mapping as described in the OVERLAY COLOR section. +Interpolation consists of linear interpolation across columns if the mask +value is one, across lines if the mask value is two, or across the shortest +direction for other values. This interpolation is done on the input data +before any spatial interpolation and filling is done. It does not modify +the input data. The task \fBfixpix\fR provides the same algorithm to fix +the data in the image. + +An overlay mask may be specified by the \fIoverlay\fR parameter. Any +value greater than zero in the overlay mask will be displayed in the color or +intensity specified by the \fIocolor\fR parameter (see the OVERLAY COLOR +section). + +Note that bad pixel masks in "pixel list" format are constrained to +non-negative values. When an image is used instead of a pixel list the +image is internally converted to a pixel list. Negative values are +set to zero or good pixels and positive real values are truncated to +the nearest integer. + +A display window is defined in terms of the full frame. The lower left +corner of the frame is (0, 0) and the upper right corner is (1, 1) as +viewed on the monitor. The display window is specified by a center +(defaulted to the center of the frame (0.5, 0.5)) and a size (defaulted to +the full size of the frame, 1 by 1). The image is loaded only within the +display window and does not affect data outside the window; though, of +course, an initial frame erase erases the entire frame. By using different +windows one may load several images in various parts of the display frame. + +If the option \fIfill\fR is selected the image and overlay mask are +spatially interpolated to fill the display window in its largest dimension +(with an aspect ratio of 1:1). When the display window is not +automatically filled the image is scaled by the magnification factors +(which need not be the same) and centered in the display window. If the +number of image pixels exceeds the number of display pixels in the window +only the central portion of the image which fills the window is loaded. By +default the display window is the full frame, the image is not interpolated +(no filling and magnification factors of 1), and is centered in the frame. +The spatial interpolation algorithm is described in the section MAGNIFY AND +FILL ALGORITHM. + +There are several options for mapping the pixel values to the display values. +There are two steps; mapping a range of image intensities to +the full display range and selecting the mapping function or +transformation. The mapping transformation is set by the parameter +\fIztrans\fR. The most direct mapping is "none" which loads the +image pixel values directly without any transformation or range +mapping. Most displays only use the lowest bits resulting in a +wrap-around effect for images with a range exceeding the display range. +This is sometimes desirable because it produces a contoured image which +is not saturated at the brightest or weakest points. +This is the fastest method of loading the display. Another +transformation, "linear", maps the selected image range linearly to the full +display range. The logarithmic transformation, "log", maps the image range +linearly between 1 and 1000 and then maps the logarithm (base 10) linearly +to the full display range. In the latter transformations pixel values +greater than selected maximum display intensity are set to the maximum +display value and pixel values less than the minimum intensity +are set to the minimum display value. + +Methods for setting of the range of image pixel values, \fIz1\fR and +\fIz2\fR, to be mapped to the full display range are arranged in a +hierarchy from an automatic mapping which gives generally good result for +typical astronomical images to those requiring the user to specify the +mapping in detail. The automatic mapping is selected with the parameter +\fIzscale\fR. The automatic mapping algorithm is described in the section +ZSCALE ALGORITHM and has three parameters, \fIzmask\fR, \fInsample\fR and +\fIcontrast\fR. + +When \fIztrans\fR = user, a look up table of intensity values and their +corresponding greyscale levels is read from the file specified by the +\fIlutfile\fR parameter. From this information, a piecewise linear +look up table containing 4096 discrete values is composed. The text +format table contains two columns per line; column 1 contains the +intensity, column 2 the desired greyscale output. The greyscale values +specified by the user must match those available on the output device. +Task \fIshowcap\fR can be used to determine the range of acceptable +greyscale levels. When \fIztrans\fR = user, parameters \fIzscale\fR, +\fIzrange\fR and \fIzmap\fR are ignored. + +If the zscale algorithm is not selected the \fIzrange\fR parameter is +examined. If \fIzrange\fR is yes then the minimum and maximum pixel values +in the image are taken from the image header or estimated from the +intensity sample and \fIz1\fR and \fIz1\fR are set to those values, +respectively. This insures that the full range of the image is displayed +but is generally slower than the zscale algorithm (because all the image +pixels must be examined) and, for images with a large dynamic range, will +generally show only the brightest parts of the image. + +Finally, if the zrange algorithm is not selected the user specifies the +values of \fIz1\fR and \fIz2\fR directly. + +Often several images are to be loaded with the same intensity and spatial +transformations. The option \fIrepeat\fR repeats the transformations from +the previous image loaded. +.ih +ZSCALE ALGORITHM +The zscale algorithm is designed to display the image values near the median +image value without the time consuming process of computing a full image +histogram. This is particularly useful for astronomical images which +generally have a very peaked histogram corresponding to the background +sky in direct imaging or the continuum in a two dimensional spectrum. + +The sample of pixels, specified by values greater than zero in the sample mask +\fIzmask\fR or by an image section, is selected up to a maximum of +\fInsample\fR pixels. If a bad pixel mask is specified by the \fIbpmask\fR +parameter then any pixels with mask values which are greater than zero are not +counted in the sample. Only the first pixels up to the limit are selected +where the order is by line beginning from the first line. If no mask is +specified then a grid of pixels with even spacing along lines and columns +that make up a number less than or equal to the maximum sample size is +used. + +If a \fIcontrast\fR of zero is specified (or the \fIzrange\fR flag is +used and the image does not have a valid minimum/maximum value) then +the minimum and maximum of the sample is used for the intensity mapping +range. + +If the contrast is not zero the sample pixels are ranked in brightness to +form the function I(i) where i is the rank of the pixel and I is its +value. Generally the midpoint of this function (the median) is very near +the peak of the image histogram and there is a well defined slope about the +midpoint which is related to the width of the histogram. At the ends of +the I(i) function there are a few very bright and dark pixels due to +objects and defects in the field. To determine the slope a linear function +is fit with iterative rejection; + + I(i) = intercept + slope * (i - midpoint) + +If more than half of the points are rejected then there is no well defined +slope and the full range of the sample defines \fIz1\fR and \fIz2\fR. +Otherwise the endpoints of the linear function are used (provided they are +within the original range of the sample): + +.nf + z1 = I(midpoint) + (slope / contrast) * (1 - midpoint) + z2 = I(midpoint) + (slope / contrast) * (npoints - midpoint) +.fi + +As can be seen, the parameter \fIcontrast\fR may be used to adjust the contrast +produced by this algorithm. +.ih +MAGNIFY AND FILL ALGORITHM +The spatial interpolation algorithm magnifies (or demagnifies) the image +(and the bad pixel and overlay masks) along each axis by the desired +amount. The fill option is a special case of magnification in that the +magnification factors are set by the requirement that the image just fit +the display window in its maximum dimension with an aspect ratio (ratio of +magnifications) of 1. There are two requirements on the interpolation +algorithm; all the image pixels must contribute to the interpolated image +and the interpolation must be time efficient. The second requirement means +that simple linear interpolation is used. If more complex interpolation is +desired then tasks in the IMAGES package must be used to first interpolate +the image to the desired size before loading the display frame. + +If the magnification factors are greater than 0.5 (sampling step size +less than 2) then the image is simply interpolated. However, if the +magnification factors are less than 0.5 (sampling step size greater +than 2) the image is first block averaged by the smallest amount such +that magnification in the reduced image is again greater than 0.5. +Then the reduced image is interpolated to achieve the desired +magnifications. The reason for block averaging rather than simply +interpolating with a step size greater than 2 is the requirement that +all of the image pixels contribute to the displayed image. If this is +not desired then the user can explicitly subsample using image +sections. The effective difference is that with subsampling the +pixel-to-pixel noise is unchanged and small features may be lost due to +the subsampling. With block averaging pixel-to-pixel noise is reduced +and small scale features still contribute to the displayed image. +.ih +OVERLAY COLORS +The masks specified by the \fIbpmask\fR and \fIoverlay\fR parameters may be +displayed as color overlays on the image data. The non-zero pixels in the +mask are assigned integer display values. The values may fall in the same +range, 1 to 200, as the mapped image pixel data values and will behave the +same way as the pixel values when the display map is interactively adjusted. +Values of 0 and 201 to 255 may be used and depend on the display server and +display resource definitions. The expected or standard server behavior is +that 0 is the background color and 201 to 255 are various colors with the +lower numbers being the more standard primary colors. The expected colors +are: + +.nf + Value Color Value Color + 201 white (cursor) 210 coral + 202 black (background) 211 maroon + 203 white 212 orange + 204 red 213 khaki + 205 green 214 orchid + 206 blue 215 turquoise + 207 yellow 216 violet + 208 cyan 217 wheat + 209 magenta +.fi + +The values 201 and 202 are tied to the cursor and background resource +colors. These are generally white and black respectively. Values above 217 +are not defined and depend on the current state of the color table for the +window system. + +The mapping between mask values and overlay colors are specified +by the \fIbpcolors\fR and \fIocolors\fR parameters. There are two mapping +syntax, a list and an expression. + +The list syntax consists of +a comma delimited set of values and assignments with one of the following +forms. + +.nf + color + maskvalue=color + maskvalue-maskvalue=color +.fi + +where color may be a color name, a color value, or value to be added or +subtracted to the mask value to yield a color value. Color names may be +black, white, red, green, blue, yellow, cyan, magenta, or transparent with +case ignored and abbreviations allowed. Transparent does the obvious of +being invisible. These values are based on the default resource colors for +the display servers (as shown above) and any custom definitions may result +in incorrect colors. + +The color values are unsigned integers (no '+' or '-') or values to be added +or subtracted are given as signed integers. The first form provides the +default intensity or color for all mask values. Note that if no default +color is specified the default will be white. The other forms map a mask +value or range of mask values to a color. In a list the last color defined +for the default or mask value will be used. + +The addition or subtraction from mask values provides a mechanism to have +the bad pixel or overlay masks encode a variety of overlay colors. Note +that to display the mask values directly as colors one would use the color +value "+0". Subtraction may produce values less than zero which then +are not visible; i.e. equivalent to "transparent". + +The following examples illustrate the features of the syntax. + +.nf + ocolors="" Display in default white + ocolors="red" Display in red + ocolors="+0" Display mask values as color values + ocolors="+200" Display mask values offset by 200 + + ocolors="205,1=red,2=yellow,10-20=cyan,30-40=+100,50-100=transparent" +.fi + +The last example has a default color of 205, mask values of 1 are +red, mask values of 2 are yellow, mask values of 10 to 20 are cyan, +and mask values of 30 to 40 are displayed as intensities 130 to 140. + +Expressions are identified by being enclosed in parentheses. +This uses the general IRAF expression syntax (see \fBexpressions\fR). +The mask values are referenced by the character $. The same named +colors (black, white, red, green, blue, yellow, cyan, magenta, +and transparent) may be used in place of color values. Expressions +must evaluate to integer values. To avoid needing special handling of +input mask values of zero, all pixels with input mask values of zero +are not shown regardless of the expression value. + +There are currently two function extensions, "colors" and "acenum". +In both functions the first and only required argument, arg1, is an integer +value. Typically this will '$' or a function based on '$'. + +The "colors" function maps input values with a modulus type behavior. The +optional second argument, arg2, is a color value for mapping zero. As noted +above, if the input mask value is zero it will not be displayed. However, +functions applied to non-zero input mask values may return a value of zero +which may then be displayed with the specified color. The default is +transparent. The next two optional arguments (arg3 and arg4) define a color +range with defaults of 204 to 217. If only arg3 is specified then +arg4 takes the value of arg3, thus having the effect of a constant +output color. Positive values of the first argument are mapped to a color +value by + +.nf + if arg1 is 0: result = arg2 + if arg1 greater 0: result = arg3 + mod ($-1, arg4-arg3+1) + otherwise: result = arg1 +.fi + +This function is primarily used to make colorful displays of regions +defined with different mask values. + +The "acenum" function handles \fBace\fR package object detection masks +which include bit flags. Each object in the mask has an object number +with value greater than 10. Values less than 10 are passed along during +detection and generally identify detector or saturated bad pixels. +Along with the object number there may be zero or more bit flags +set. This function removes the bit flags and returns the mask number. +The optional second argument, arg2, is a string of letters which selects +pixels with certain sets of bit flags. The bit flags are: + +.nf + B -- a bad pixel treated as a good for detection + D -- original detection (i.e. without G or S flag) + E -- edge pixel used for displaying detection isophotes + F -- object contains a bad pixel + G -- grown pixel + S -- pixel not assigned to an object during splitting +.fi + +The default of arg2 is "BDEG" which essentially returns all pixels +in an object. + +The acenum function also returns 0 for the pixels with values between +one and ten and -1 for the pixels not selected by the flags. The value +of zero may be made visible using the colors function. The two functions +are often used in concert: + +.nf + (colors(acenum($))) + (colors(acenum($),black)) + (colors(acenum($,'E'),red,green) +.fi + +Note that when filling and anti-aliasing the behavior of the overlay +colors may be different than intended. +.ih +EXAMPLES +For the purpose of these examples we assume a display with four frames, +512 x 512 in size, and a display range of 0 to 255. Also consider two +images, image1 is 100 x 200 with a range 200 to 2000 and image2 is +2000 x 1000 with a range -1000 to 1000. To load the images with the +default parameters: + +.nf + cl> display image1 1 + cl> display image2 2 +.fi + +The image frames are first erased and image1 is loaded in the center of +display frame 1 without spatial interpolation and with the automatic intensity +mapping. Only the central 512x512 area of image2 is loaded in display frame 2 + +To load the display without any intensity transformation: + + cl> cvl image1 1 ztrans=none + +The next example interpolates image2 to fill the full 512 horizontal range +of the frame and maps the full image range into the display range. Note +that the spatial interpolation first block averages by a factor of 2 and then +magnifies by 0.512. + + cl> display image2 3 fill+ zscale- + +The next example makes image1 square and sets the intensity range explicitly. + + cl> display image1 4 zscale- zrange- z1=800 z2=1200 xmag=2 + +The next example loads the two images in the same frame side-by-side. + +.nf + cl> display.xsize=0.5 + cl> display image1 fill+ xcen=0.25 + cl> display image2 erase- fill+ xcen=0.75 +.fi +.ih +REVISIONS +.ls DISPLAY V2.11 +The bad pixel mask, overlay mask, sample mask, and overlay colors +parameters and functionality have been added. The "nsample_lines" +parameter is now an "nsample" parameter. + +Bugs in the coordinate system sent to the image display for cursor +readback were fixed. +.le +.ih +BUGS +The "repeat" option is not implemented. +.ih +SEE ALSO +cvl, magnify, implot, minmax, fixpix +.endhelp diff --git a/pkg/images/tv/doc/imedit.hlp b/pkg/images/tv/doc/imedit.hlp new file mode 100644 index 00000000..66b113af --- /dev/null +++ b/pkg/images/tv/doc/imedit.hlp @@ -0,0 +1,493 @@ +.help imedit Aug07 images.tv +.ih +NAME +imedit -- examine and edit pixels in images +.ih +USAGE +imedit input output +.ih +PARAMETERS +.ls input +List of images to be edited. Images must be two dimensional. +.le +.ls output +List of output images. The list must match the input list or be empty. +In the latter case the output image is the same as the input image; i.e. +the edited image replaces the input image. +.le +.ls cursor = "" +The editing commands are entered via a cursor list. When the task is +run interactively this will normally be the standard image cursor +(stdimcur) specified by a null string. Commands may be read from +a file. The file format may be cursor values including the command +keys, a simple list of positions with the default command given +by the \fIdefault\fR parameter, and a regions file, as used in +the task \fBfixpix\fR and the \fBccdred\fR package, selected by +the \fIfixpix\fR parameter. +.le +.ls logfile = "" +File in which to record the editing commands which modify the images. +The display and statistics commands which don't modify the images are +not recorded. This file may be used for keeping a record of the +modifications. It may also be used as cursor input for other images +to replicate the same editing operations. +.le +.ls display = yes +Display the image during editing? If yes then the display command, +given by the parameter \fIcommand\fR, is used to display the image. +Normally the display is used when editing interactively and turned +off when using file input. +.le +.ls autodisplay = yes +Automatically redisplay the image after each change? If the display +of the image is rapid enough then each change can be displayed as +it is made by setting this parameter to yes. However, it is faster +to accumulate changes and then explicitly redisplay the image. +When the parameter is no then the image is only redisplayed by +explicit command. +.le +.ls autosurface = no +Automatically display surface plots after each change? In addition +to the image display command, the task can display a before and after +surface plot of the modified region. This can be done by explicit +command or automatically after each change. +.le +.ls aperture = "circular" +Aperture for aperture editing. Some commands specify the region to +be edited by a center and radius. The shape of the aperture is selected +by this parameter. The choices are "circular" and "square". Note that +this does not apply to commands in which a rectangle is specified by +selecting the corners. +.le +.ls radius = 2. +Radius of the aperture for commands selecting an aperture. For circular +apertures this is the radius while for square apertures it is half of the +side of the square. Note that partial pixels are not used so that a +circular aperture is not perfectly circular; i.e. if the center of a +pixel is within this distance of the center pixel it is modified and +otherwise it is not. A radius of zero may be used to select a single +pixel (with either aperture type). +.le +.ls search = 2. +Search radius for adjusting the position of the region to be edited. +This applies to both aperture regions and rectangular regions. The +center pixel of the region is searched within this radius for the +maximum or minimum pixel value. If the value is zero then no searching +is done and the specified region is used directly. If the value is +positive then the specified region is adjusted to be centered on a +relative maximum. A relative minimum may be found if the value is +negative with the absolute value used as the search radius. +.le +.ls buffer = 1. +Background buffer width. A buffer annulus separates the region to be +edited from a background annulus used for determining the background. +It has the same shape as the region to be edited; i.e. circular, square, +rectangular, or line. +.le +.ls width = 2. +Width of background annulus. The pixels used for background determinations +is taken from an annulus of the same shape as the region to be edited and +with the specified width in pixels. +.le +.ls xorder = 2, yorder = 2 +Orders (number of terms) of surface polynomial fit to background pixels +for statistics and background subtraction. The orders should generally +be low with orders of 2 for a plane background. If either order is +zero then a median background is used. +.le +.ls value = 0. +Value for constant substitution. One editing command is replacement of +a region by this value. +.le +.ls minvalue = INDEF, maxvalue = INDEF +Range of values which may be modified. Value of INDEF map to the minimum +and maximum possible values. +.le +.ls sigma = INDEF +Sigma of noise to be added to substitution values. If less than or +equal to zero then no noise is added. If INDEF then pixel values from +the background region are randomly selected after subtracting the +fitted background surface or median. Finally if a positive value is given than +a gaussian noise distribution is added. +.le +.ls angh = -33., angv = 25. +Horizontal and vertical viewing angles (in degrees) for surface plots. +.le +.ls command = "display $image 1 erase=$erase fill=yes order=0 >& dev$null" +Command for displaying images. This task displays images by executing a +standard IRAF command. Two arguments may be substituted by the appropriate +values; the image name specified by "$image" and the boolean erase +flag specified by "$erase". Except for unusual cases the \fBtv.display\fR +command is used with the fill option. The fill option is required to +provide a zoom feature. See the examples for another possible command. +.le +.ls graphics = "stdgraph" +Graphics device used for surface plots. Normally this is the standard +graphics device "stdgraph" though other possibilities are "stdplot" +and "stdvdm". Note the standard graphics output may also be +redirected to a file with ">G file" where "file" is any file name. +.le +.ls default = "b" +Default command option for simple position list input. If the input +is a list of column and line positions (x,y) then the command executed +at each position is given by this parameter. This should be one of +the aperture type editing commands, the statistics command, or the +surface plotting command. Two keystroke commands would obviously +be incorrect. \fIThis parameter is ignored in "fixpix" mode\fR. +.le +.ls fixpix = no +Fixpix style input? This type of input consists of rectangular regions +specified by lines giving the starting and ending column and starting +and ending line. This is the same input used by \fBfixpix\fR and in +the \fBccdred\fR package. The feature to refer to "untrimmed" images +in the latter package is not available in this task. When selected +the editing consists of interpolation across the narrowest dimension +of the region and the default key is ignored. +.le +.ih +DESCRIPTION +Regions of images are examined and edited. This may be done interactively +using an image display and cursor or non-interactively using a list of +positions and commands. There are a variety of display and editing +options. A list of input images and a matching list of output images +are specified. The output images are only created if the input image +is modified (except by an explicit "write" command). If no output +list is specified (an empty list given by "") then the modified images +are written back to the input images. The images are edited in +a temporary buffer image beginning with "imedit". + +Commands are given via a cursor list. When the task is run +interactively this will normally be the standard image cursor +(stdimcur). Commands may be read from a file. The file format may be +cursor values including the command keys, a simple list of positions +with the default command given by the \fIdefault\fR parameter, and a +regions file, as used in the task \fBfixpix\fR and the \fBccdred\fR +package, selected by the \fIfixpix\fR parameter. + +The commands which modify the image may be written to a log file specified +by parameter \fIlogfile\fR. This file can be used as a record of the +pixels modified. The format of this file is also suitable for input +as a cursor list. This allows the same commands to be applied to other +images. \fIBe careful not to have the cursor input and logfile have the +same name!\fR + +When the \fIdisplay\fR parameter is set the command given by the parameter +\fIcommand\fR is executed. Normally this command loads the image display +though it could also create a contour map or other graph whose x and y +coordinates are the same as the image coordinates. The image is displayed +when editing interactively and the standard image cursor (which can +be redefined to be the standard graphics cursor) is used to select +regions to be edited. When not editing interactively the display +flag should be turned off. + +It is nice to see changes to the image displayed immediately. This is +possible using the \fIautodisplay\fR option. Note that this requires +the display parameter to also be set. If the autodisplay flag is set +the display command is repeated after each change to the image. The +drawback to this is that the full image (or image section) is reloaded +and so can be slow. If not set it is still possible to explicitly give +a redisplay command, 'r', after a number of changes have been made. + +Another display option is to make surface graphs to the specified +graphics device (normally the standard graphics terminal). This may +be done by the commands 'g' and 's' and automatically after each +change if the \fIautosurface\fR parameter is set. The two types of +surface plots are a single surface of the image at the marked position +and before and after plots for a change. + +Regions of the image to be examined or edited are selected by one +or two cursor commands. The single cursor commands define the center +of an aperture. The shape of the aperture, circular or square, is +specified by the \fIaperture\fR parameter and the radius (or half +the edge of a square) is specified by the \fIradius\fR parameter. +The radius may be zero to select a single pixel. The keys '+' and +'-' may be used to quickly increment or decrement the current radius. +The two keystroke commands either define the corners of a rectangular +region or the endpoints of a line. + +Because it is sometimes difficult to mark cursor position precisely +the defined region may be shifted so that the center is either +a local maximum or minimum. This is usually desired for editing +cosmicrays, bad pixels, and stars. The center pixel of the aperture +is moved within a specified search radius given by parameter +\fIsearch\fR. If the search radius is zero then the region defined +by the cursor is not adjusted. The sign of the search radius +selects whether a maximum (positive value) or a minimum (negative value) +is sought. The special key 't' toggles between the two modes +in order to quickly edit both low sensitivity bad pixels and +cosmicrays and stars. + +Once a region has been defined a background region may be required +to estimate the background for replacement. The background +region is an annulus of the same shape separated by a buffer width, +given by the parameter \fIbuffer\fR, and having a width given by +the parameter \fIwidth\fR. + +The replacement options are described below as is a summary of all the +commands. Two commands requiring a little more description are the +space and 'p' commands. These print the statistics at the cursor +position for the current aperture and background parameters. The +printout gives the x and y position of the aperture center (after the +search if any), the pixel value (z) at that pixel, the mean background +subtracted flux in the aperture, the number of pixels in the aperture, +the mean background "sky", the sigma of the background residuals from +the background fit, and the number of pixels in the background region. +The 'p' key additionally prints the pixel values in the aperture. +Beware of apertures with radii greater than 5 since they will wrap +around in an 80 column terminal. + +When done editing or examining an image exit with 'q' or 'Q'. The +former saves the modified image in the output image (which might be +the same as the input image) while the latter does not save the +modified image. Note that if the image has not been modified then +no output occurs. After exiting the next image in the input +list is edited. One may also change input images using the +":input" command. Note that this command sets the output to be the +same as the input and a subsequent ":output" command should be +used to define a different output image name. A final useful +colon command is ":write" which forces the current editor buffer +to be written. This can be used to save partial changes. +.ih +REPLACEMENT ALGORITHMS +The parameters "minvalue" and "maxvalue" are may be used to limit the +range of values modified. The default is to modify all pixels which +are selected as described below. + +.ls a, b +Replace rectangular or aperture regions by background values. A background +surface is fit the pixels in the background annulus if the x and y orders +are greater than zero otherwise a median is computed. The x and y orders +of the surface function are given by the \fIxorder\fR and \fIyorder\fR +parameters. The median is used or the surface is evaluated for the pixels +in the replacement region. If a positive sigma is specified then gaussian +noise is added. If a sigma of INDEF is specified then the residuals of the +background pixels are sorted, the upper and lower 10% are excluded, and the +remainder are randomly selected as additive noise. +.le +.ls c, f, l +Replace rectangular or line regions by interpolation from the nearest +background column or line. The 'f' line option interpolates across the +narrowest dimension; i.e. for lines nearer to the line axis interpolation +is by lines while for those nearer to the column axis interpolation is +by columns. The buffer region applies but only the nearest background +pixel at each line or column on either side of the replacement region +is used for interpolation. Gaussian noise may be added but background +sampling is not available. This method is similar to the method used +in \fBfixpix\fR or \fBccdred\fR with no buffer. For "fixpix" type +input the type of interpolation is automatically selected for the +narrower dimension with column interpolation for square regions. +.le +.ls d, e, v +Replace rectangular, aperture, or vector regions by the specified +constant value. This may be used to flag pixels or make masks. +The vector option makes a line between two points with a width +set by the radius value. +.le +.ls j, k +Replace rectangular or aperture regions in the editor buffer by the data +from the input image. This may be used to undo any change. Note that +the 'i' command can be used to completely reinitialize the editor +buffer from the input image. +.le +.ls m, n +Replace an aperture region by another aperture region. There is no +centering applied in this option. The aperture region to copy is +background subtracted using the background annulus for median or surface +fitting. This data may then be added to the destination aperture or +replace the data in the destination aperture. In the latter case the +destination background surface is also computed and added. +.le +.ls u +Undo the last change. When a change is made the before and after data +are saved. An undo exchanges the two sets of data. Note that it is +possible to undo an undo to restore a change. If any other command is +used which causes data to be read (including the statistics and surface +plotting) then the undo is lost. +.le +.ls =, <, > +The all pixels with a value equal to that of the pixel at the cursor +position are replaced by the specified constant value. This is intended +for editing detection masks where detected objects have specific mask +values. +.le +.ih +COMMANDS +.ce + IMEDIT CURSOR KEYSTROKE COMMANDS + +.nf + ? Print help + : Colon commands (see below) + Statistics + g Surface graph + i Initialize (start over without saving changes) + q Quit and save changes + p Print box of pixel values and statistics + r Redraw image display + s Surface plot at cursor + t Toggle between minimum and maximum search + + Increase radius by one + - Decrease radius by one + I Interrupt task immediately + Q Quit without saving changes +.fi + +The following editing options are available. Rectangular, line, and +vector regions are specified with two positions and aperture regions +are specified by one position. The current aperture type (circular or +square) is used in the latter case. The move option takes two positions, +the position to move from and the position to move to. + +.nf + a Background replacement (rectangle) + b Background replacement (aperture) + c Column interpolation (rectangle) + d Constant value substitution (rectangle) + e Constant value substitution (aperture) + f Interpolation across line (line) + j Replace with input data (rectangle) + k Replace with input data (aperture) + l Line interpolation (rectangle) + m Copy by replacement (aperture) + n Copy by addition (aperture) + u Undo last change (see also 'i', 'j', and 'k') + v Constant value substitution (vector) + = Constant value substitution of pixels equal + to pixel at the cursor position + < Constant value substitution of pixels less than or equal + to pixel at the cursor position + > Constant value substitution of pixels greater than or equal + to pixel at the cursor position +.fi + +When the image display provides a fill option then the effect of zoom +and roam is provided by loading image sections. This is a temporary +mechanism which will eventually be replaced by a more sophisticated +image display interface. + +.nf + E Expand image display + P Pan image display + R Redraw image display + Z Zoom image display + 0 Redraw image display with no zoom + 1-9 Shift display +.fi + + +.ce +IMEDIT COLON COMMANDS + +The colon either print the current value of a parameter when there is +no value or set the parameter to the specified value. + +.nf +angh [value] Horizontal viewing angle (degrees) +angv [value] Vertical viewing angle (degrees) +aperture [type] Aperture type (circular|square) +autodisplay [yes|no] Automatic image display? +autosurface [yes|no] Automatic surface plots? +buffer [value] Background buffer width +command [string] Display command +display [yes|no] Display image? +eparam Edit parameters +graphics [device] Graphics device +input [image] New input image to edit (output name = input) +output [image] New output image name +radius [value] Aperture radius +search [value] Search radius +sigma [value] Noise sigma (INDEF for histogram replacement) +value [value] Constant substitution value +minvalue [value] Minimum value for modification (INDEF=minimum) +maxvalue [value] Maximum value for modification (INDEF=maximum) +width [value] Background annulus width +write [name] Write changes to name (default current output) +xorder [value] X order for background fitting +yorder [value] Y order for background fitting +.fi +.ih +KEYWORDS +None +.ih +EXAMPLES +1. Interactively edit an image. + + cl> imedit raw002 ed002 + +2. Edit pixels non-interactively from an x-y list. Replace the original images + by the edited images. + +.nf + cl> head bad + 20 32 + 40 91 + + cl> imedit raw* "" cursor=bad display- +.fi + +3. It is possible to use a contour plot for image display. This is really + not very satisfactory but can be used in desperation. + +.nf + cl> reset stdimcur=stdgraph + cl> display.command="contour $image >& dev$null" + cl> imedit raw002 ed002 +.fi + +4. Use a "fixpix" file (without trim option). + +.nf + cl> head fixpix + 20 22 30 80 + 99 99 1 500 + + cl> imedit raw* %raw%ed%* cursor=fixpix fixpix+ display- +.fi +.ih +REVISIONS +.ls IMEDIT V2.13 +The 'v' option was added to allow vector replacement. +The '=', '<', '>' options were added to replace values matching the pixel +at the cursor. +.le +.ls IMEDIT V2.11.2 +The temporary editor image was changed to use a unique temporary image +name beginning with "imedit" rather than the fixed name of "epixbuf". +.le +.ls IMEDIT V2.11 +If xorder or yorder are zero then a median background is computed +for the 'a' and 'b' keys. +.le +.ls IMEDIT V2.10.4 +The 'u', 'j', 'k', and 'n' keys were added to those recorded in the +log file. +.le +.ls IMEDIT V2.8 +This task is a first version of what will be an evolving task. +Additional features and options will be added as they are suggested. +It is also a prototype using a very limited display interface; execution +of a separate display command. Much better interaction with a variety +of image displays will be provided after a planned "image display +interface" is implemented. Therefore any deficiencies in this area +should be excused. + +The zoom and roam features provided here are quite useful. However, +they depend on a feature of the tv.display program which fills the +current image display window by pixel replication or interpolation. +If this is left out of the display command these features will not +work. The trick is that this task displays sections of the editor +buffer whose size and position is based on an internal zoom and +center and the display program expands the section to fill the +display. + +The surface plotting is done using an imported package. The limitations +of this package (actually limitations in the complexity of interfacing +the application to this sophisticated package) mean that the +surface plots are always scaled to the range of the data and that +it is not possible to label the graph or use the graphics cursor to +point at features for the task. +.le +.ih +SEE ALSO +ccdred.instruments proto.fixpix +.endhelp diff --git a/pkg/images/tv/doc/imexamine.hlp b/pkg/images/tv/doc/imexamine.hlp new file mode 100644 index 00000000..14dbb59d --- /dev/null +++ b/pkg/images/tv/doc/imexamine.hlp @@ -0,0 +1,1043 @@ +.help imexamine Mar96 images.tv +.ih +NAME +imexamine -- examine images using image display, plots, and text +.ih +USAGE +imexamine [input [frame]] +.ih +PARAMETERS +.ls input +Optional list of images to be examined. If specified, images are examined +in turn, displaying them automatically. If no images are specified the +images currently loaded into the image display are examined. +.le +.ls output = "" +Rootname for output images created with the 't' key. If no name is specified +then the name of the input image is used. A three digit number is appended +to the rootname, such as ".001", starting with 1 until no image is found with +that name. Thus, successive output images with the same rootname will be +numbered sequentially. +.le +.ls ncoutput = 101, nloutput = 101 +Size of the output image created with the 't' key which is centered on the +position of the cursor. +.le +.ls frame = 1 +During program execution, a query parameter specifying the frame to be loaded. +May also be specified on the command line when \fIimexamine\fR is used as a +task to display a new image, to specify the frame to be loaded. +.le +.ls image +Query parameter for selecting images to be loaded. +.le +.ls logfile = "" +Logfile filename in which to record output of the commands producing text. +If no filename is given then no logfile will be kept. +.le +.ls keeplog = no +Log output results initially? Logging can be toggled interactively during +program execution. +.le +.ls defkey = "a" +Default key for cursor x-y input list. This key is applied to input +cursor lists which do not have a cursor key specified. It is used +to repetitively apply a cursor command to a list of positions typically +obtained from another task. +.le +.ls autoredraw = yes +Automatically redraw graphs after a parameter change? If no then graphs +are only drawn when a graph or redraw command is given. +If yes then colon commands which modify a parameter of the last graph +will automatically redraw the graph. A common example of this would +be changing the graph limits. +.le +.ls allframes = yes +Use all frames for displaying images? If set, images from the input list +are loaded cycling through the available frames. If not set the last frame +loaded is reused. +.le +.ls nframes = 0 +Number of display frames. When automatically loading images from the input +list only this number of frames will be used. This should, of course, +not exceed the number of frames provided by the display device. +If the number of frames is set to 0 then the task will query the display +device to determine how many frames are currently allocated. New frames may +be allocated during program execution by displaying images with the 'd' key. +.le +.ls ncstat = 5, nlstat = 5 +The statistics command computes values from a box centered on the +specified cursor position with the number of columns and lines +given by these parameters. +.le +.ls graphcur = "" +Graphics cursor input. If null the standard graphics cursor is used whenever +graphics cursor input is requested. A cursor file in the appropriate +format may be substituted by specifying the name of the file. +.le +.ls imagecur = "" +Image display cursor input. If null the standard image display cursor is +used whenever image cursor input is requested. A cursor file in the +appropriate format may be substituted by specifying the name of the file. +Also the image cursor may be changed to query the graphics device or +the terminal by setting the environment parameter "stdimcur" +to "stdgraph" or "text" respectively. +.le +.ls wcs = "logical" +The world coordinate system (\fIwcs\fR) to be used for axis labeling when +input is from images. +The following standard world systems are predefined. +.ls logical +Logical coordinates are image pixel coordinates relative to the image currently +being displayed. +.le +.ls physical +The physical coordinate system is invariant with respect to linear +transformations of the physical image matrix. For example, if the reference +image was created by extracting a section of another image, the physical +coordinates of an object in the reference image will be the pixel coordinates +of the same object in the original image. The physical coordinate system +thus provides a consistent coordinate system (a given object always has the +same coordinates) for all images, regardless of whether any user world +coordinate systems have been defined. +.le +.ls world +The "world" coordinate system is the \fIcurrent default WCS\fR. +The default world system is the system named by the environment variable +\fIdefwcs\fR if defined in the user environment and present in the reference +image WCS description, else it is the first user WCS defined for the image +(if any), else physical coordinates are returned. +.le +.ls xformat = "", yformat = "" +The numerical format for the world coordinate labels in the line and column +plots and the format for printing world coordinates. The values may be "" +(an empty string), %f for decimal format, %h and %H for xx:xx:xx format, and +%m and %M for xx:xx.x format. The upper case %H and %M convert degrees +to hours. Images sometimes include recommended coordinate formats as +WCS attributes. These are used if the format specified by these parameters +is "". Any other value will override the image attribute. +.le + +In addition to these three reserved WCS names, the name of any user WCS +defined for the reference image may be given. A user world coordinate system +may be any linear or nonlinear world system. +.le +.ls graphics = "stdgraph" +Graphics output device. Normally this is the standard graphics device +specified by the environment variable "stdgraph". +.le +.ls display = "display(image='$1',frame=$2)" +Command template used to display an image. The image to be displayed is +substituted for argument $1 and the frame for argument $2. Any display task +may be used for image display by modifying this template. +.le +.ls use_display = yes +Use the image display? Set to no to disable all interaction with the +display device, e.g., when working at a terminal that does not provide image +display capabilities. +.le +.ih +ADDITIONAL PARAMETERS +The various graphs and the aperture sum command have parameters defined in +additional parameter sets. The parameter sets are hidden tasks with +the first character being the cursor command graph key that uses the +parameters followed by "imexam". The parameter sets are: + +.nf + cimexam Parameters for column plots + eimexam Parameters for contour plots + himexam Parameters for histogram plots + jimexam Parameters for line 1D gaussian fit plots + kimexam Parameters for column 1D gaussian fit plots + limexam Parameters for line plots + rimexam Parameters for radial profile plots and aperture sums + simexam Parameters for surface plots + vimexam Parameters for vector plots (centered and endpoint) +.fi + +The same parameters dealing with graph formats occur in many of the parameter +sets while some are specific only to one parameter set. In the +summary below those common to more than one parameter set are shown +only once. The characters in parenthesis are the graph key prefixes +for the parameter sets in which the parameter occurs. + +.ls angh = -33., angv = 25. (s) +Horizontal and vertical viewing angles (degrees) for surface plots. +.le +.ls autoscale = yes (h) +In the case of integer data, automatically adjust \fInbins\fR and +\fIz2\fR to avoid aliasing effects. +.le +.ls axes = yes (s) +Draw axes along edge of surface plots? +.le +.ls background = yes (jkr.) +Fit and subtract a background for aperture sums, 1D gaussian fits, and +radial profile plots? +.le +.ls banner = yes (cehjklrsv.) +Add a standard banner to a graph? The standard banner includes the +IRAF user and host identification and time, the image name and title, +and graph specific parameters. +.le +.ls beta = INDEF (ar.) +Beta value to use for Moffat profile fits. If the value is INDEF +the value will be determine as part of the fit otherwise the parameter +will be fixed at the specified value. +.le +.ls boundary = "constant" (v) +Boundary extension for vector plots in which the averaging width might +go outside of the image. +.le +.ls box = yes (cehjklrv.) +Draw graph box and axes? +.le +.ls buffer = 5. (r.) +Buffer distance from object aperture of background annulus for aperture sums +and radial profile plots. +.le +.ls ceiling = INDEF (es) +Ceiling data value for contour and surface plots. A value of INDEF does +not apply a ceiling. (In contour plots a value of 0. also does not +apply a ceiling.) +.le +.ls center = yes (jkr.) +Apply a centering algorithm for doing aperture sums, 1D gaussian fits, +and radial profile plots? +.le +.ls constant = 0. (v) +Boundary extension constant for vector plots in which the averaging width +might go outside of the image. +.le +.ls dashpat = 528 (e) +Dash pattern for negative contours. +.le +.ls fill = no (e) +Fill the output viewport regardless of the device aspect ratio? +.le +.ls fitplot = yes (r.) +Overplot the profile fit on the radial profile data? +.le +.ls fittype = "moffat" (ar.) +Profile type to fit the radial profile data? The choices are "gaussian" +and "moffat". +.le +.ls floor = INDEF (es) +Floor data value for contour and surface plots. A value of INDEF does +not apply a floor. (In contour plots a value of 0. also does not +apply a floor.) +.le +.ls interval = 0 (e) +Contour interval. If 0, a contour interval is chosen which places 20 to 30 +contours spanning the intensity range of the image. +.le +.ls iterations = 3 (ar) +Number of iterations to adjust the fitting radius. +.le +.ls label= no (e) +Label the major contours in the contour plot? +.le +.ls logx = no, logy = no (chjklrv.) +Plot the x or y axis logarithmically? The default for histogram plots is +to plot the y axis logarithmically. +.le +.ls magzero = 25. (r.) +Magnitude zero point for aperture sums. +.le +.ls majrx=5, minrx=5, majry=5, minry=5 (cehjklrv.) +Maximum number of major tick marks on each axis and number of minor tick marks +between major tick marks. +.le +.ls marker = "box" (chjklrv.) +Marker to be drawn if \fBpointmode\fR = yes. Markers are "point", "box", +"cross", "plus", "circle", "hebar", "vebar", "hline", "vline" or "diamond". +.le +.ls naverage = 1 (cjklv) +Number of lines, columns, or width perpendicular to a vector to be averaged. +.le +.ls nbins = 512 (h) +The number of bins in, or resolution of, histogram plots. +.le +.ls ncolumns = 21, nlines = 21 (ehs) +Number of columns and lines used in contour, histogram, and surface plots. +.le +.ls ncontours = 5 (e) +Number of contours to be drawn. If 0, the contour interval may be specified, +otherwise 20-30 nicely spaced contours are drawn. A maximum of 40 contours +can be drawn. +.le +.ls nhi = -1 (e) +If -1, highs and lows are not marked. If 0, highs and lows are marked +on the plot. If 1, the intensity of each pixel is marked on the plot. +.le +.ls pointmode = no (chlv) +Plot points or marks instead of lines? +.le +.ls pointmode = yes (jkr.) +Plot points or marks instead of lines? For radial profile plots point +mode should always be yes. +.le +.ls radius = 5. (r.) +Radius of aperture for aperture sums and centering. +.le +.ls round = no (cehjklrv.) +Extend the axes up to "nice" values? +.le +.ls rplot = 8. (jkr.) +Radius to which the radial profile or 1D profile fits are plotted. +.le +.ls sigma = 2. (jk) +Initial guess for 1D gaussian fits. The value is in pixels even if the fitting +is done in world coordinates. This must be close to the true value +for convergence. Also the four times the initial sigma is used to define +the distance to the background region for the initial background estimate. +.le +.ls szmarker = 1 (chjklrv.) +Size of mark (except for points). A positive size less than 1 specifies +a fraction of the device size. Values of 1, 2, 3, and 4 signify +default sizes of increasing size. +.le +.ls ticklabels = yes (cehjklrv.) +Label the tick marks? +.le +.ls title = "" (cehjklrsv.) +User title. This is independent of the standard banner title. +.le +.ls top_closed = no (h) +Include z2 in the top histogram bin? Each bin of the histogram is a +subinterval that is half open at the top. \fITop_closed\fR decides whether +those pixels with values equal to z2 are to be counted in the histogram. If +\fBtop_closed\fR is yes, the top bin will be larger than the other bins. +.le +.ls width = 5. (jkr.) +Width of background region for background subtraction in aperture sums, +1D profile fits, and radial profile plots. +.le +.ls wcs = "physical" +World coordinate system for axis labeling and coordinate readback. +.le +.ls x1 = INDEF, x2 = INDEF, y1 = INDEF, y2 = INDEF (chjklrv.) +Range of graph along each axis. If INDEF the range is determined from +the data range plus a buffer. The default y1 for histogram plots is 0. +.le +.ls xformat, yformat +Set world image coordinate formats. Any format changes take effect on the next +usage; i.e. there is no automatic redrawing. +.le +.ls xlabel, ylabel (cehjklrv.) +Axis labels. Each graph type has an appropriate default. If the label +value is "wcslabel" then the coordinate label from the image WCS +will be used if defined. +.le +.ls xorder = 0 (jk) +Order for 1D gaussian background. If 0 then a median is computed. If +1 then a constant background is fit simultaneously with the other gaussian +parameters. If 2 then a linear background is fit simultaneously with the +other gaussian parameters. +.le +.ls xorder = 0, yorder = 0 (r.) +If either parameter is zero then the median value of the +background annulus is used for background subtraction in aperture sums and +radial profile plots. Values greater than zero define polynomial +surface orders for background subtraction. The orders are actually the +number of polynomial terms. An order of 1 is a constant an order of 2 +is a plane. +.le +.ls zero = 0. (e) +Greyscale value of the zero contour, i.e., the value of a zero point shift +to be applied to the image data before plotting. Does not affect the values +of the floor and ceiling parameters. +.le +.ls z1 = INDEF, z2 = INDEF (h) +Range of pixel values to be used in histogram. INDEF values default to +the range in the region being histogramed. +.le +.ih +DESCRIPTION +Images are examined using an image display, various types of plots, and +text output. Commands are given using the image display cursor and/or +graphics cursor. This task brings together many of the features of the +IRAF image display and graphics facilities with some simple image +analysis capabilities. + +IMAGE DISPLAY + +If \fIuse_display\fR is yes the image display is used to examine images. +When no input list is specified images may be loaded with the 'd' key, +frames selected with 'n', 'p', and ":select", and the scaled contents +of the display frame buffer examined if the image itself is not available. + +When an input list is specified the 'n', 'p', and ":select" allow +moving about the list and new images may be added to the end of the +list with 'd'. Images are automatically loaded as they are selected if +not currently loaded. Two parameters control how the frames are +loaded. The \fInframes\fR parameter determines which frames are +available. Within the available frames images may be loaded by cycling +through them if \fIallframes\fR is yes or in the last loaded frame +(initially frame 1) if it is no. + +When reading the image cursor the frame and the name of the image in +the frame are determined. Therefore images may also be selected +by changing the frame externally or if the image cursor input is +changed from the standard image display to text or file input. + +The 'd' command displays an image using the template CL command given +by parameter \fIdisplay\fR. Usually this is the standard +IRAF \fBtv.display\fR command though in some circumstances other commands +like \fBplot.contour\fR may be used. This command may be used to +display an image even if \fIuse_display\fR is no. + +This task is generally intended for interactive use with an image +display. However it is possible to disable use of the image display +and change the image cursor input to a graphics cursor, a file, +or typed in by the user. In this case an input image list is most +appropriate but if one is missing, a query will be issued each time +a command requiring an image is given. + +CURSOR INPUT + +Commands are given using cursor input. Generally the image cursor is +used to select points in the images to be examined and the key typed +selects a particular operation. In addition to the image cursor the +graphics cursor is sometimes useful. First, it gives access to the +graphics cursor mode commands (see \fBcursors\fR) such as annotating, +saving or printing a graph, expanding and roaming, and printing cursor +positions. Second, it can give a better perspective on the data for +cursor positions than the image cursor. And lastly, it may be needed +when an image display is not available. The commands 'g' and 'i' +select between the graphics and image cursors. Initially the image +cursor is read. + +Interpretation of the graph coordinate in terms of an image coordinate +depends on the type of graph as described below. + +.ls contour plot +This gives image coordinates directly and both the x and y cursor values +are used. +.le +.ls column plot +The x cursor position gives the line coordinate and the column coordinate +used for the plot (that specified before averaging) gives the column +coordinate. +.le +.ls line plot +The x cursor position gives the column coordinate and the line coordinate +used for the plot (that specified before averaging) gives the line +coordinate. +.le +.ls vector plot +The x cursor position defines a column and line coordinate along the vector +plotted. +.le +.ls surface plot +No cursor information is available in this plot and the cursor position +used to make the surface plot (the center of the surface) is used again. +.le +.ls histogram plot +No cursor information is available in this plot and the cursor position +used to make the histogram (the center of the box) is used again. +.le +.ls radial profile plot +No cursor information is available in this plot and the cursor position +used to define the center is used again. +.le + +There are some special features associated with cursor input in IRAF +which might be useful in some circumstances. The image display cursor +can be reset to be a text cursor, graphics cursor, or image cursor by +setting the environment variable "stdimcur" to "text", "stdgraph", +or "stdimage" respectively. Text cursor input consists of the x and +y coordinates, a frame number, and the key or colon command. Another +form of text input is to set the value of the cursor input parameter +to a file containing cursor commands. There are two special features +dealing with text cursor input. If only x and y are entered the default +key parameter \fIdefkey\fR determines the command. This is particularly +useful if one has a list of pixel positions prepared by some other +program. The second feature is that for commands not requiring coordinates +they may be left out and the command key or colon command entered. + +TEXT OUTPUT + +The following commands produce text output which may also be appended to +a logfile. + +.ls a, ',' +Circular aperture photometry is performed at the position of the cursor. +If the centering option is selected the cursor position is used as the +initial point for computing the central moments of the marginal +distributions in x and y. The marginal distributions are obtained from a +square aperture with edge dimensions of twice the aperture radius +parameter. Only the pixels above the mean are used in computing the +central moments. If the central moments are in a different pixel than that +used for extracting the marginal distributions the computation is repeated +using the new center. + +The radius of the photometry and fitting aperture is specified by the +\fIradius\fR parameter and the \fIiteration\fR parameter. Iteration of the +fitting radius and printing of the final radius is only done for the 'a' +key. If the number of iterations is one then the radius is not adjusted. +If it is greater than one then the direct FWHM (described) below is used to +adjust the radius. At each iteration the new radius is set to three times +the direct FWHM (which is six times the radius at half-maximum). The +radius is printed as part of the output. + +If the background subtraction option is selected a concentric circular +annulus is defined. The inner edge is separated from the object +aperture by a specified buffer distance and the outer edge is defined +by a width for the annulus. The type of background used is determined +by the parameters \fIxorder\fR and \fIyorder\fR. If either parameter +is zero then a median of the background annulus is determined. +If 1 or greater a polynomial surface of the specified number of terms +is fit. Typically the orders are 1 for a constant or 2 for a plane. +The median or fitted surface values within the object aperture are then +subtracted. + +The flux within the circular aperture is computed by simply summing the +pixel values with centers within the specified radius of the center +position. No partial pixel adjustments are made. If the flux is +positive a magnitude is computed as + + magnitude = magzero - 2.5 * log10 (flux) + +where the magnitude zero point is a user defined parameter. + +In addition to the flux, the second intensity moments are used to compute +an ellipticity and position angle. The equations defining the moments and +related parameters are: + +.nf + Mxx = sum (x * x * I) / sum (I) + Myy = sum (y * y * I) / sum (I) + Mxy = sum (x * y * I) / sum (I) + e = sqrt ((Mxx - Myy) ** 2 + (2 * Mxy) ** 2) / (Mxx + Myy) + pa = 0.5 * atan (2 * Mxy / (Mxx - Myy)) +.fi + +A nonlinear least squares profile of fixed center and zero background is +fit to the radius and flux values of the background subtracted pixels to +determine a peak intensity and FWHM. The profile type is set by the +\fIfittype\fR parameter. The choices are "gaussian" and "moffat". If the +profile type is "moffat" there is an additional parameter "beta". This +value may be specified to fix it or given as INDEF to also be determined. +The profile equations are: + +.nf + I = Ic exp (-0.5 * (r / sigma)**2) (fittype = "gaussian") + I = Ic (1 + (r / alpha)**2)**(-beta) (fittype = "moffat") +.fi + +where Ic is the peak value, r is the radius, and the parameters are +sigma, alpha, and beta. The sigma and alpha values are converted to +FWHM in the reported results. + +Weights which are the inverse square of the pixel radius are used. This +has the effect of giving equal weight to all parts of the profile instead +of being overwhelmed by the larger number of pixels are larger radii. An +additional weighting factor is used for pixels outside the half-maximum +radius (as determined using the algorithm described below). The weights +are + +.nf + wt = exp (-(r/rhalf - 1)**2) for r/rhalf > 1 +.fi + +where rhalf is the radius at half-maximum. This has the effect +of reducing the contribution of the profile wings. + +The above fit is done to the individual pixel values with a radius measured +to the center of the pixel. For the 'a' key two additional measurements +are made on a azimuthally averaged radial profile with a finer sampling of +the radial bins. This uses the same algorithms for centering, background +estimation, and FWHM measurement as in the task \fBpsfmeasure\fR. The +centering is essentially the same as described above but the background +estimation is a mode of the sky annulus pixels. Note that the centering +and background subtraction are done for these measurements regardless of +the the \fIcenter\fR and \fIbackground\fR parameters which apply only to +the photometry and profile fitting to the individual pixel values. + +To form the radially smoothed profile an image interpolator function is fit +to the region containing the object. The enclosed flux profile (total flux +within a particular radius) is computed. The sampling is done at a much +finer resolution than individual pixels. The subsampling scheme is that +described in \fBpsfmeasure\fR and is such that the center of the profile is +more finely sampled than the edges of the profile. + +Because the image interpolator function may not be very good for narrow +profiles a second iteration is done if the radius enclosing half the flux +is less than two pixels. In this second iteration an analytic, radially +symmetric Gaussian profile is subtracted from the image raster and the +interpolation function is fit to the residuals. Subpixel values are then +computed by evaluating the analytic function plus the interpolated residual +value. + +There are two FWHM measurements computed using the enclosed flux +radial profile. One is to fit a Gaussian or Moffat profile to the +enclosed flux profile. The type is selected by the same \fIfittype\fR +parameter used to select the profile to fit to the individual pixel +values. As with the direct fit the Moffat beta value may be fixed or +included in the fit. The FWHM of the fit is then printed on the +status line, terminal output, and log file. + +The other FWHM measurement directly measure the FWHM independent of a +profile model. The derivative of the enclosed flux profile is computed. +This derivative is the azimuthally averaged radial profile with the radial +bin sampling mentioned above. The peak of this profile is found and the +FWHM is twice the radius of the profile at half the peak value. This +"direct FWHM" is part of the output and is also used for the iterative +adjustment of the fitting radius as noted above. + +.ls a +The output consists of the image line and column, the coordinates, the +final radius used for the photometry and fitting, magnitude, flux, mean +background, peak value of the profile fit, e, pa (in degrees between -90 +and +90 with 0 along the x axis), the Moffat beta value if a Moffat profile +is fit, and three measures of the FWHM. The coordinates are those +specified by the \fIwcs\fR and formatted by the format parameters. For the +logical wcs the coordinates will be the same as the column and line +values. If a value is numerically undefined then INDEF is printed. The +FWHM values are, in order, the profile fit to the enclosed flux, the +profile fit to the individual pixels, and the direct measurement from the +derivative of the enclosed flux profile. Note that except for the direct +method, the other estimates are not really measurements of the FWHM but are +quantities which give the correct FWHM for the specified profile type. +.le +.ls ',' +The output consists of the image line and column, magnitude, flux, number +of pixels within the aperture, mean background, r (moment FWHM), e, pa (in +degrees between -90 and +90 with 0 along the x axis), and the peak value +and FWHM of the profile fit. The label GFWHM indicates a Gaussian fit +while the label MFWHM indicates a Moffat profile fit. If a quantity is +numerically undefined then INDEF is printed. +.le + +This aperture photometry and FWHM tool is intended only for general image +analysis and quick look measurements. The background fitting, photometry, +and FWHM techniques used are not intended for serious astronomical +photometry; other packages, e.g., \fInoao.digiphot.apphot\fR, should be +used if precise results are desired. +.le +.ls b +The integer pixel coordinates defining a region of the image are printed. +Two cursor positions are used to select the range of columns and lines. +The output format consists of the starting and ending column +coordinates and the starting and ending line coordinates. This format is +used as input by some tasks and can be used to generate image sections if +desired. +.le +.ls j, k +The fitted gaussian center, peak, sigma, full width at half maximum, and +background at the center is computed and printed. +.le +.ls m +Statistics of a rectangular region centered on the cursor position are +computed and printed. The size of the statistics box is set by the +parameters \fIncstat\fR and \fInlstat\fR. The output format consists +of the image section, the number of pixels, the mean, the median, the +standard deviation, the minimum, and the maximum. +.le +.ls x, y +The cursor x and y coordinates and the pixel value nearest this position +are printed. The 'y' key may be used define a relative origin. If +an origin is defined (is not 0,0) then additional quantities are printed. +These quantities are origin coordinates, the delta x and delta y distances, +the radial distance, and the position angle (in degrees counterclockwise from +the x axis). +.le +.ls z +A 10x10 grid of pixel values is printed. The integer coordinates are +also printed around the grid. +.le + +GRAPHICS OUTPUT + +The following commands produce graphics output to the specified graphics +device (normally the graphics terminal). + +.ls c +A plot of a column or average of columns is made with the line number as +the ordinate and the pixel value as the abscissa. The averaging number +and various graph options are specified by the parameters from the +\fBcimexam\fR parameter set. +.le +.ls e +A contour plot of a region centered on the cursor is made. The +size of the region and various contouring and labeling options are +specified by the parameters from the \fBeimexam\fR parameter set. +.le +.ls h +A histogram of a region centered on the cursor is made. The size +of the region and various binning parameters are specified by +the parameters from the \fBhimexam\fR parameter set. +.le +.ls l +A plot of a line or average of lines is made with the column number as +the ordinate and the pixel value as the abscissa. The averaging number +and various graph options are specified by the parameters from the +\fBlimexam\fR parameter set. +.le +.ls r, '.' +A radial profile plot is made. As with 'a'/',' there are options for centering +and background subtraction. There are also graphics option to set the +radius to be plotted (\fIrplot\fR) and to overplot the profile fit +(\fIfitplot\fR). The measurement algorithms are those described for the +'a'/',' key and the output is the same except that there is no header line and +the object center is given in the graph title rather than on the graphics +status line. The aperture sum and graph options are specified by the +parameters from the \fBrimexam\fR parameter set. +.le +.ls s +A surface plot of a region centered on the cursor is made. The size +of the region and various surface and labeling options are +specified by the parameters from the \fBsimexam\fR parameter set. +.le +.ls u, v +A plot of a vector defined by two cursor positions is made. The 'u' +plot uses the first cursor position to define the center of the vector +and the second position to define the endpoint. The vector is extended +an equal distance in the opposite direction and the graph x coordinates +are the radial distance from the center position. The 'v' plot +uses the two cursor positions as endpoints and the coordinates are +the radial distance from the first cursor position. The vector may +be averaged over a specified number of parallel vectors. The +averaging number and various graph options are specified by the parameters +from the \fBvimexam\fR parameter set. +.le + + +MISCELLANEOUS COMMANDS + +The following commands control useful features of the task. + +.ls d +The display command given by the parameter \fIdisplay\fR is given +with appropriate image name. By default this loads the image +display using the \fBtv.display\fR task. When using an input image +list this operation also appends new images to the list for subsequent +'n' and 'p' commands. +.le +.ls f +Redraw the last graph. If the \fIautoredraw\fR parameter is no then +this is used to redraw a graph after making parameter changes with +colon commands. If the parameter is yes then any colon command which +affects the current plot will execute a redraw automatically. +.le +.ls g, i +Cursor input may be selected to be from the graphics cursor (g) or +image display cursor (i). +.le +.ls n, p +Go to the next or previous image in the image list or display frames. +.le +.ls o +Overplot the next graph. This generally only makes sense with the +line, column, and histogram plots. +.le +.ls q +Quit the task. +.le +.ls t +Output an image centered on the cursor position with name and size set +by the \fIoutput\fR, \fIncoutput\fR and \fInloutput\fR parameters. +Note that the cursor input might be from a contour, surface, or other +plot as well as from the image display. +.le +.ls w +Toggle output to the logfile. If no logfile is specified this has no +effect except to print a message. If the logfile is specified a message +is printed indicating that the logfile has been opened or closed. +Every time the logfile is opened the current image name and title is +entered as well as when the image is changed. The logfile name may +be set or changed by a colon command. +.le +.ls :select +Select an image. If an input image list is used the specified index +number selects an image from the list. If an input image list is not +used and the image display is used then the specified display frame +is selected. If the new image is different from the previous image +an identification line is inserted in the logfile if it is open. +.le +.ls :eparam, :unlearn +These colon commands manipulate the various parameter sets as +described below. +.le +.ls :c<#>, :l<#> +Special colon commands to plot specific columns or lines, symbolically +shown as <#>, rather than use a cursor position. +.le +.ls : +Special colon command syntax to explicitly give image coordinates for +a cursor command key. +.le + +COLON COMMANDS + +Sometimes one wants to explicitly enter the coordinates for a command. +This may be done with a colon command having the following syntax: + + : + +where column and line are the coordinates and key is the command. +If the line is not given then = . For the frequently +used line and column plots there is also the simple syntax: + +.nf + :c or :l +.fi + +with no space, e.g., ":l64". + +Every parameter except the input image list and the display command +may be queried or set by a +colon command. In addition the parameter sets for the various graphs +and aperture sum algorithm may be edited using the \fBeparam\fR editor +and reinitialized to default values using the \fBunlearn\fR command. +There are a large number of parameters as well as many graph types / +parameter sets. To achieve some consistency and order as well as +simplify the colon commands several things have been done. + +Many parameters occur in more than one graph type. This includes things +like graph labeling, tickmarks, and so forth. When issuing a colon +command for one of these parameters the current graph type is assumed +to be the one affected. If the graph type is wrong or no graph has +been made then a warning is given. + +If the parameter only occurs in one parameter set then the colon command +may be used with any current graph. However, if the parameter affects the +current graph and the automatic redraw option is set then the graph will +be redrawn. + +The eparam and unlearn commands also apply by default to the parameters +for the current graph. However, they may take the keystroke character +for the graph as an argument to override this. If the current graph +parameters are changed and the automatic redraw option is set then +the graph will be redrawn. + +The important colon commands 'x' and 'y' affect the x1, y1, x2, y2 +parameters in most of the graphs. They are frequently used to override +the automatic graph scaling. If no arguments are given the window +limits are set to INDEF resulting in plotting the full range of the +data plus a buffer. If two values are given then only that range of +the data will be plotted. + +.ih +COMMANDS + +.ce +Cursor Keys + +.nf +? Print help +a Aperture sum, moment parameters, and profile fit +b Box coordinates for two cursor positions - c1 c2 l1 l2 +c Column plot +d Load the image display +e Contour plot +f Redraw the last graph +g Graphics cursor +h Histogram plot +i Image cursor +j Fit 1D gaussian to image lines +k Fit 1D gaussian to image columns +l Line plot +m Statistics + image[section] npixels mean median stddev min max +n Next frame or image +o Overplot +p Previous frame or image +q Quit +r Radial profile plot with fit and aperture sum values +s Surface plot +t Output image centered on cursor (parameters output, ncoutput, nloutput) +u Centered vector plot from two cursor positions +v Vector plot between two cursor positions +w Toggle write to logfile +x Print coordinates + col line pixval [xorign yorigin dx dy r theta] +y Set origin for relative positions +z Print grid of pixel values - 10 x 10 grid +, Quick Gaussian/Moffat photometry +. Quick Gaussian/Moffat radial profile plot and fit +.fi + +.ce +Colon Commands + +Explicit image coordinates may be entered using the colon command syntax: + + : + +where column and line are the image coordinates and the key is one +of the cursor keys. A special syntax for line or column plots is also +available as :c# or :l# where # is a column or line and no space is +allowed. + +Other colon commands set or show parameters governing the plots and other +features of the task. Each graph type has it's own set of parameters. +When a parameter applies to more than one graph the current graph is assumed. +If the current graph is not applicable then a warning is given. The +"eparam" and "unlearn" commands may be used to change many parameters and +without an argument the current graph parameters are modified while with +the graph key as an argument the appropriate parameter set is modified. +In the list below the graph key(s) to which a parameter applies are shown. + +.nf +allframes Cycle through all display frames to display images +angh s Horizontal angle for surface plot +angv s Vertical angle for surface plot +autoredraw cehlrsuv Automatically redraw graph after colon command? +autoscale h Adjust number of histogram bins to avoid aliasing +axes s Draw axes in surface plot? +background jkr Subtract background for radial plot and photometry? +banner cehjklrsuv Include standard banner on plots? +beta ar Moffat beta parameter (INDEF to fit or value to fix) +boundary uv Boundary extension type for vector plots +box cehjklruv Draw box around graph? +buffer r Buffer distance for background subtraction +ceiling es Data ceiling for contour and surface plots +center jkr Find center for radial plot and photometry? +constant uv Constant value for boundary extension in vector plots +dashpat e Dash pattern for contour plot +eparam cehjklrsuv Edit parameters +fill e Fill viewport vs enforce unity aspect ratio? +fitplot r Overplot profile fit on data? +fittype ar Profile fitting type (gaussian|moffat) +floor es Data floor for contour and surface plots +interval e Contour interval (0 for default) +iterations ar Iterations on fitting radius +label e Draw axis labels for contour plot? +logfile Log file name +logx chjklruv Plot x axis logarithmically? +logy chjklruv Plot y axis logarithmically? +magzero r Magnitude zero for photometry +majrx cehjklruv Number of major tick marks on x axis +majry cehjklruv Number of major tick marks on y axis +marker chjklruv Marker type for graph +minrx cehjklruv Number of minor tick marks on x axis +minry cehjklruv Number of minor tick marks on y axis +naverage cjkluv Number of columns, lines, vectors to average +nbins h Number of histogram bins +ncolumns ehs Number of columns in contour, histogram, or surface plot +ncontours e Number of contours (0 for default) +ncoutput Number of columns in output image +ncstat Number of columns in statistics box +nhi e hi/low marking option for contours +nlines ehs Number of lines in contour, histogram, or surface plot +nloutput Number of lines in output image +nlstat Number of lines in statistics box +output Output image root name +pointmode chjkluv Plot points instead of lines? +radius r Radius of object aperture for radial plot and photometry +round cehjklruv Round axes to nice values? +rplot jkr Radius to plot in 1D and radial profile plots +select Select image or display frame +sigma jk Initial sigma for 1D gaussian fits +szmarker chjklruv Size of marks for point mode +ticklabels cehjklruv Label ticks? +title cehjklrsuv Optional title for graph +top_closed h Close last bin of histogram +unlearn cehjklrsuv Unlearn parameters to default values +wcs World coordinate system for axis labels and readback +width jkr Width of background region +x [min max] chjklruv Range of x to be plotted (no values for autoscaling) +xformat Coordinate format for column world coordinates +xlabel cehjklrsuv Optional label for x axis +xorder jkr X order of surface for background subtraction +y [min max] chjklruv Range of y to be plotted (no values for autoscaling) +yformat Coordinate format for line world coordinates +ylabel cehjklrsuv Optional label for y axis +yorder r Y order of surface for background subtraction +z1 h Lower intensity value limit of histogram +z2 h Upper intensity value limit of histogram +zero e Zero level for contour plot +.fi +.ih +EXAMPLES +The following example illustrates many of the features in a descriptive +way using the standard image dev$pix. + +.nf + cl> imexam dev$pix nframes=2 + [The image is loaded in the display if not already loaded] + l # Make a line plot + e # Make a contour plot + d # Load a new image + image name: saga + display frame (1:) (1): 2 + e # Make a contour plot + g # Switch to graphics cursor + u # Mark the center of a vector + u # Mark endpoint make a vector plot + i # Go back to display + r # Select star and make radial plot + :rplot 10 # Set radius of plot + :epar # Set radius plot parameters + c # Make column plot + :100 l # Line 100 of image 1 + :20 30 e # Contour plot at (20,30) + p # Go to previous image + n # Go to next image + :sel 1 # Select image 1 + :log log # Set log file + w # Begin logging + Log file log is open + a # Do aperture sum on star 1 + a # Do aperture sum on star 2 + a # Do aperture sum on star 3 + a # Do aperture sum on star 4 + w # Close log file + Log file log is closed + y # Mark position of galaxy center + x # Print position relative to center + x # Print position relative to center + s # Make surface plot + q # Quit +.fi +.ih +BUGS +If an operation is interrupted, e.g., an image display or surface plot, +\fIimexamine\fR is terminated rather than the operation in progress. + +When used on a workstation \fIimexamine\fR attempts to always position the +cursor to the window (text, image, or graphics) from which input is being +taken. Moving the mouse manually while the program is also trying to move +it can cause the mouse to be positioned to the wrong window, requiring that +it be manually moved to the window from which input is currently being taken. + +When entering a colon command in image cursor mode, if one types too fast +the characters typed before the mouse is moved to the input window +will be lost. To avoid this, pause a moment after typing the colon, before +entering the command, and verify that the mouse has been moved to the correct +window. In the future colon command input will be entered without moving +the mouse out of the image window, which will avoid the problem. +.ih +REVISIONS +.ls IMEXAMINE V2.11.4 +('t'): A new cursor key to create an output image. +.le +.ls IMEXAMINE V2.11 +('a' and 'r'): The fit to the radial profile points now includes both a +Gaussian and a Moffat profile. The Moffat profile exponent parameter, +beta, may be fixed or left free to be fit. + +('a' and 'r'): New estimates of the FWHM were added to the 'a' and 'r' +keys. These include the Moffat profile fit noted above, a direct +measurement of the FWHM from the radially binned profile, and a Gaussian or +Moffat fit to the radial enclosed flux profile. The output from these keys +was modified to include the new information. + +('a' and 'r'): The direct FWHM may be used to iteratively adjust the +fitting radius to lessen the dependence on the initial fitting +radius value. + +(',' and '.'): New keys to do the Gaussian or Moffat fitting without +iteration or the enclosed flux and direct measurements. The output +format is the same as the previous version. + +('k'): Added a kimexam parameter set. +.le +.ih +SEE ALSO +cursors, eparam, unlearn, plot.*, tvmark, digiphot.*, apphot.*, +implot, splot, imedit, radplt, imcntr, imhistogram, imstatistics, display +psfmeasure. +.endhelp diff --git a/pkg/images/tv/doc/tvmark.hlp b/pkg/images/tv/doc/tvmark.hlp new file mode 100644 index 00000000..b6611b22 --- /dev/null +++ b/pkg/images/tv/doc/tvmark.hlp @@ -0,0 +1,405 @@ +.help tvmark Dec89 images.tv +.ih +NAME +tvmark -- mark objects on the image display +.ih +USAGE +tvmark frame coords +.ih +PARAMETERS +.ls frame +The frame or image plane number of the display to be marked. +.le +.ls coords +The text file containing the coordinates of objects to be +marked, one object per line with x and y in columns 1 and 2 respectively. +An optional label may be read out of the third column. +If \fIcoords\fR = "", the coordinate file is undefined. +.le +.ls logfile = "" +The text file in which image cursor commands typed in interactive mode +are logged. If \fIlogfile\fR = "" no commands are logged. +If automatic logging is enabled, all cursor commands +are logged, otherwise the user must use the interactive keep keystroke +command to select specific cursor commands for logging. +Commands are not logged in non-interactive mode. +.le +.ls autolog = no +Automatically log all cursor commands in interactive mode. +.le +.ls outimage = "" +The name of the output snapshot image. +If tvmark is run in non-interactive mode and no command file is specified, +a copy of the frame buffer +is automatically written to the IRAF image \fIoutimage\fR after tvmark +terminates execution. +If \fIoutimage\fR = "" no output image is written. +In interactive mode or in non-interactive mode if a command file +is specified, the user can make snapshots of the frame buffer +with the interactive colon write command. In this case the name of the output +snapped image will be in order of priority, the name specified +by the user in the colon write ommand, "outimage.snap.version", or, +"imagename.snap.version". +.le +.ls deletions = "" +The extension of the output file containing objects which were deleted +from the coordinate file in interactive or command file mode. +By default no output deletions file is written. +If \fIdeletions\fR is not equal to the null string (""), then deleted +objects are written to a file called \fIcoords.deletions\fR. For +example if \fIcoords\fR = "nite1" and \fIdeletions\fR = "del", then the +deletions file will be called "nite1.del". +.le +.ls commands = "" +The text file containing the marking commands. +In interactive mode if \fIcommands\fR = "", +\fIcommands\fR is the image cursor. In non-interactive mode +cursor commands may be read from a text file, by setting \fIcommands\fR = +"textfile". This file may be a user +created command file, or the \fIlogfile\fR from a previous run of tvmark. +If \fIcommands\fR = "" in non-interactive mode, the default mark is drawn +on the display at the positions of all the objects in \fIcoords\fR. +.le +.ls mark = "point" +The default mark type. The options are: +.ls point +A point. To ensure legibility \fIpoint\fR is actually a square dot whose +size is specified by \fIpointsize\fR. +.le +.ls plus +A plus sign. The shape of the plus sign is determined by the raster font +and its size is specified by \fItxsize\fR. +.le +.ls cross +An x. The shape of the x is determined by the raster font and its size is +is specified by \fItxsize\fR. +.le +.ls circle +A set of concentric circles whose radii are specified by the \fIradii\fR +parameter. The radii are in image pixel units. If the magnifications +used by display are not equal in x and y circles will become ellipses +when drawn. +.le +.ls rectangle +A set of concentric rectangles whose lengths and width/length ratio are +specified by the \fIlengths\fR parameter. The lengths are specified in +image pixel units. If the magnifications used by the display are not +equal in x and y then squares will become rectangles when drawn. +.le +.le +.ls radii = "0" +If the default mark type is "circle" than concentric circles of radii +"r1,r2,...rN" are drawn around each selected point. +.le +.ls lengths = "0" +if the default mark type is "rectangle" then concentric rectangles of +length and width / length ratio "l1,l2,...lN ratio" are drawn around +each selected point. If ratio is not supplied, it defaults to 1.0 +and squares are drawn. +.le +.ls font = "raster" +The name of the font. At present only a simple raster font is supported. +.le +.ls color = 255 +The numerical value or color of the marks drawn. +Any number between 0 and 255 may be specified. +The meaning of the color is device dependent. +In the current version of the Sun/IRAF IMTOOL numbers between 202 +and 217 may be used to display graphics colors. The current color +assignments for IMTOOL are summarized later in this help page. +.le +.ls label = no +Label the marked coordinates with the string in the third column of +the text file \fIcoords\fR. \fIlabel\fR overrides \fInumber\fR. +.le +.ls number = no +Label the marked objects with their sequence number in the coordinate +list \fIcoords\fR. +.le +.ls nxoffset = 0, nyoffset = 0 +The x and y offset in display pixels of the numbers to be drawn. +Numbers are drawn by default with the lower left corner of the first +digit at the coordinate list position. +.le +.ls pointsize = 3 +The size of the default mark type "point". Point size will be rounded up +to the nearest odd number. +.le +.ls txsize = 1 +The size of text, numbers and the plus and cross marks to be written. +The size is in font units which are 6 display pixels wide and 7 display +pixels high. +.le +.ls tolerance = 1.5 +Objects marked by the cursor for deletion from the coordinate list +\fIcoords\fR must be less than or equal to \fItolerance\fR pixels +from the cursor position to be deleted. If 1 or more objects +is closer than \fItolerance\fR, the closest object is deleted. +.le +.ls interactive = no +Interactive mode. +.le +.ih +DESCRIPTION +TVMARK marks objects on the display by writing directly into +the frame buffer specified by \fIframe\fR. TVMARK can draw on +any devices supported by the IRAF \fIdisplay\fR program. +After marking, the +contents of the frame buffer may be written out to the IRAF image +\fIoutimage\fR. The output image is equal in size and intensity +to the contents of the frame buffer displayed at the time of writing. + +In interactive mode objects to be marked may be selected interactively +using the image cursor or read from the text file \fIcoords\fR. +Objects in the coordinate list +may be selected individually by number, +in groups by specifying a range of numbers, or the entire list may +be read. New objects may be added to the list interactively +using the append keystroke command. In batch mode cursor commands +may be read from a text file by setting \fIcommands\fR to the name +of the text file. This may be a user created file of cursor +commands or a log file from a previous interactive run of TVMARK. +If no command file is specified then all the objects in the coordinate +list are marked with the default mark type /fImark/fR. + +The mark commands entered in interactive mode can be saved in the text +file \fIlogfile\fR. If \fIautolog\fR +is enabled and \fIlogfile\fR is defined all cursor commands +are automatically logged. If \fIautolog\fR is turned off then the user +can select which commands are to be logged interactively using the +interactive keep keystroke. + +The default mark type are currently "none", "point", "plus", "cross", +"circle", a +list of concentric circles, and "rectangles", a list of concentric rectangles. +The size of the "point" mark is set using the parameter \fIpointsize\fR +while the sizes of the "plus" and "cross" mark types are set by the +\fItxsize\fR parameter. Txsize is in font units which for the simple raster +font currently implemented is six display pixels in x and seven display +pixels in y. +The \fIradii\fR and \fIlengths\fR parameters +describe the concentric circles and concentric rectangles to be drawn +respectively. +If \fInumber=yes\fR then objects in the coordinate list will be automatically +numbered as well as marked. The position of the number can be altered +with the \fInxoffset\fR and \fInyoffset\fR parameters. + +In interactive mode tvmark maintains a scratch buffer. The user opens +the scratch buffer by issuing a save command which saves the current +contents of the frame buffer in a temporary IRAF image. +The user can continue marking and if unsatisfied with the results +restore the last saved copy of the frame buffer with the restore +command. Subsections of the saved frame buffer can be restored to the +current frame buffer with the erase keystroke command. +Finally a snapshot of the frame buffer can be saved permanently by +using the write command. These snapped images can be redisplayed +by setting the display task parameter \fIztrans\fR = "none". +.ih +CURSOR COMMANDS + +.nf + Interactive TVMARK Keystroke/Colon Commands + +The following keystroke commands are available. + + ? Print help + + Mark the cursor position with + + x Mark the cursor position with x + . Mark the cursor position with a dot + c Draw defined concentric circles around the cursor position + r Draw defined concentric rectangles around the cursor position + s Draw line segments, 2 keystrokes + v Draw a circle, 2 keystrokes + b Draw a rectangle, 2 keystrokes + f Draw filled rectangle, 2 keystrokes + e Mark region to be erased and restored, 2 keystrokes + + - Move to previous object in the coordinate list + m Move to next object in the coordinate list + p Mark the previous object in the coordinate list + n Mark next object in the coordinate list + l Mark all the objects in the coordinate list + o Rewind the coordinate list + a Append object at cursor position to coordinate list and mark + d Delete object nearest the cursor position in the coordinate list + and mark + + k Keep last cursor command + q Exit tvmark + +The following colon commands are available. + + :show List the tvmark parameters + :move N Move to Nth object in coordinate list + :next N M Mark objects N to M in coordinate list + :text [string] Write text at the cursor position + :save Save the current contents of frame buffer + :restore Restore last saved frame buffer + :write [imagename] Write the contents of frame buffer to an image + +The following parameters can be shown or set with colon commands. + + :frame [number] + :outimage [imagename] + :coords [filename] + :logfile [filename] + :autolog [yes/no] + :mark [point|line|circle|rectangle|cross|plus] + :radii [r1,...,rN] + :lengths [l1,...,lN] [width] + :font [raster] + :color [number] + :number [yes/no] + :label [yes/no] + :txsize [1,2,..] + :pointsize [1,3,5...] +.fi + +.ih +CURRENT IMTOOL COLORS + +.nf + 0 = sunview background color (normally white) + 1-200 = frame buffer data values, windowed + 201 = cursor color (white) + + 202 = black + 203 = white + 204 = red + 205 = green + 206 = blue + 207 = yellow + 208 = cyan + 209 = magenta + 210 = coral + 211 = maroon + 212 = orange + 213 = khaki + 214 = orchid + 215 = turquoise + 216 = violet + 217 = wheat + + 218-254 = reserved for use by other windows + 255 = black (sunview foreground color) +.fi + +.ih +EXAMPLES +1. Display an image, mark all the objects in the coordinate file +m92.coo.1 with red dots, and save the contents of the frame buffer +in the iraf image m92r.snap. Redisplay the marked image. + +.nf + cl> display m92r 1 + cl> tvmark 1 m92.coo.1 outimage=m92r.snap col=204 + cl> display m92r.snap 2 ztrans="none" +.fi + +2. Execute the same command only number the objects in the coordinate +list instead of marking them. + +.nf + cl> display m92r 1 + cl> tvmark 1 m92.coo.1 outimage=m92r.snap mark=none\ + >>> number+ col=204 + cl> display m92r.snap 2 ztrans="none" +.fi + +3. Display an image and draw concentric circles with radii of 5, 10 and +20 pixels corresponding to an aperture radius and inner and outer +sky annulus around the objects in the coordinate list. + +.nf + cl> display m92r 1 + cl> tvmark 1 m92.coo.1 mark=circle radii="5,10,20" col=204 +.fi + +4. Display an image, mark objects in a coordinate list with dots +and append new objects to the coordinate file. + +.nf + cl> display m92r 1 + + cl> tvmark 1 m92.coo.1 interactive+ + ... type q to quit the help menu ... + ... type :number yes to turn on numbering ... + ... type l to mark all objects in the coordinate file + ... move cursor to desired unmarked objects and type a + ... type :write to take a snap shot of the frame buffer + ... type q to quit +.fi + +5. Make a finder chart of a region containing 10 stars by drawing +a box around the field, marking each of the 10 stars with a dot, +labeling each with an id and finally labeling the whole field. +Save all the keystroke commands in a log file. + +.nf + cl> display m92r 1 log=m92r.log auto+ + + cl> tvmark 1 "" interactive+ + + ... type q to quit the help menu ... + + ... to draw a box around the finder field move the cursor to the + lower left corner of the finder field and type b, move the + cursor the upper right corner of the field and type b again + + ... to mark and label each object move to the position of the + object and type ., next move slightly away from the object + and type :text id + + ... to label the chart with a title first type :txsize 2 for + bigger text then move the cursor to the position where + the title should begin and type :text title + + ... save the marked image with :write + + ... type q to quit the program +.fi + +6. Edit the log file created above to remove any undesired commands +and rerun tvmark redirecting cursor input to the log file. + +.nf + cl> display m92r 1 + cl> tvmark 1 "" commands=logfile inter- +.fi + +7. Draw a box on the display with a lower left corner of 101,101 and an +upper right corner of 200,200 using a simple cursor command file. +Note than in interactive mode the b key is the one that draws a box. + +.nf +The command file contains the following 3 lines + + 101.0 101.0 101 b + 200.0 200.0 101 b + 200.0 200.0 101 q + + cl> display m92r 1 + cl> tvmark 1 "" commands=commandfile inter- +.fi +.ih +BUGS +Tvmark is a prototype task which can be expected to undergo considerable +modification and enhancement in the future. The current version of this +task does not produce publication quality graphics. +In particular aliasing is easily visible in the code which draws circles +and lines. + +Input from the coordinate list is sequential. No attempt has been made +to arrange the objects to be marked in order for efficiency of input and +output. + +Note that the move command does not currently physically move the image +cursor. However the next mark drawn will be at the current coordinate +list position. + +Users may wish to disable the markcur option in the imtool setup window +before running tvmark. +.ih +SEE ALSO +display, imedit, imexamine +.endhelp diff --git a/pkg/images/tv/doc/wcslab.hlp b/pkg/images/tv/doc/wcslab.hlp new file mode 100644 index 00000000..0095c68c --- /dev/null +++ b/pkg/images/tv/doc/wcslab.hlp @@ -0,0 +1,698 @@ +.help wcslab Dec91 images.tv + +.ih +NAME +wcslab -- overlay a labeled world coordinate grid on an image + +.ih +USAGE +wcslab image + +.ih +PARAMETERS + +.ls image +The name of the image to be labeled. If image is "", the parameters +in wcspars will be used to draw a labeled coordinate grid. +.le +.ls frame +The display frame buffer displaying the image to be labeled. +.le +.ls usewcs = no +Use the world coordinate system specified by the parameters in the wcspars +parameter set in place of the image world coordinate system or if +image is "" ? +.le +.ls wcspars = "" +The name of the parameter set defining the world coordinate system +to be used if image is "" or if usewcs = "yes". The wcspars parameters +are described in more detail below. +.le +.ls wlpars = "" +The name of the parameter set which controls the +detailed appearance of the plot. The wlpars parameters are described +in more detail below. +.le +.ls fill = yes +If fill is no, wcslab tries to +create a square viewport with a maximum size dictated by the viewport +parameters. If fill is yes, then wcslab +uses the viewport exactly as specified. +.le +.ls vl = INDEF, vr = INDEF, vb = INDEF, vt = INDEF +The left, right, bottom, and top edges of the viewport in NDC (0-1) +coordinates. If any of vl, vr, vb, or vt are INDEF, +wcslab computes a default value. To overlay the plot +with a displayed image, vl, vr, vb, and vt must use the same viewport used +by the display task to load the image into the frame buffer. +.le +.ls overplot = no +Overplot to an existing plot? If yes, wcslab will not erase the +current plot. This differs from append in that a new viewport +may be defined. Append has priority if both +append and overwrite are yes. +.le +.ls append = no +Append to an existing plot? If no, wcslab resets the +graphics to a new viewport/wcs for each new plot. Otherwise, it uses +the scaling from a previous plot. If append=yes but no plot was drawn, it +will behave as if append=no. This differs from overplot in that +the same viewport is used. Append has priority if both +append and overwrite are yes. +.le +.ls device = "imd" +The graphics device. To create an overlay plot, device must be set +to one of the imdkern devices listed in dev$graphcap. To create a +plot of the coordinate grid in the +graphics window, device should be set to "stdgraph". +.le + +.ih +WCSPARS PARAMETERS + +.ls ctype1 = "linear", ctype2 = "linear" +The coordinate system type of the first and second axes. +Valid coordinate system types are: +"linear", and "xxx--tan", "xxx-sin", and "xxx-arc", where "xxx" can be either +"ra-" or "dec". +.le +.ls crpix1 = 0.0, crpix2 = 0.0 +The X and Y coordinates of the reference point in pixel space that +correspond to the reference point in world space. +.le +.ls crval1 = 0.0, crval2 = 0.0 +The X and Y coordinate of the reference point in world space that +corresponds to the reference point in pixel space. +.le +.ls cd1_1 = 1.0, cd1_2 = 0.0 +The FITS CD matrix elements [1,1] and [1,2] which describe the x-axis +coordinate transformation. These elements usually have the values + and, <-yscale * sin (angle)>, or, for ra/dec systems +<-xscale * cos (angle)> and . +.le +.ls cd2_1 = 0.0, cd2_2 = 1.0 +The FITS CD matrix elements [2,1] and [2,2] which describe the y-axis +coordinate transformation. These elements usually have the values + and . +.le +.ls log_x1 = 0.0, log_x2 = 1.0, log_y1 = 0.0, log_y2 = 1.0 +The extent in pixel space over which the transformation is valid. +.le + + +.ih +WLPARS PARAMETERS + +.ls major_grid = yes +Draw a grid instead of tick marks at the position of the major +axes intervals? If yes, lines of constant axis 1 and axis 2 values +are drawn. If no, tick marks are drawn instead. Major grid +lines / tick marks are labeled with the appropriate axis values. +.le +.ls minor_grid = no +Draw a grid instead of tick marks at the position of the +minor axes intervals? If yes, lines of constant axis 1 and axis 2 values +are drawn between the major grid lines / tick +marks. If no, tick marks are drawn instead. Minor grid lines / tick +marks are not labeled. +.le +.ls dolabel = yes +Label the major grid lines or tick marks? +.le +.ls remember = no +Modify the wlpars parameter file when done? If yes, parameters that have +been calculated by the task are written back to the parameter file. +If no, the default, the parameter file is left untouched by the task. +This option is useful for fine-tuning the appearance of the graph. +.le +.ls axis1_beg = "" +The lowest value of axis 1 in world coordinates units +at which a major grid line / tick mark will be drawn. +If axis1_beg = "", wcslab will compute this quantity. +Axis1_beg will be ignored if axis1_end and axis1_int are undefined. +.le +.ls axis1_end = "" +The highest value of axis 1 in world coordinate +units at which a major grid line / tick mark will be drawn. +If axis1_end = "", wcslab will compute this quantity. +Axis1_end will be ignored if axis1_beg and axis1_int are undefined. +.le +.ls axis1_int = "" +The interval in world coordinate units at which +major grid lines / tick marks will be drawn along axis 1. +If axis1_int = "", wcslab will compute this quantity. +Axis1_int will be ignored if axis1_beg and axis1_end are undefined. +.le +.ls axis2_beg = "" +The lowest value of axis 2 in world coordinates units +at which a major grid line / tick mark will be drawn. +If axis2_beg = "", wcslab will compute this quantity. +Axis2_beg will be ignored if axis2_end and axis2_int are undefined. +.le +.ls axis2_end = "" +The highest value of axis 2 in world coordinate +units at which a major grid line / tick mark will be drawn. +If axis2_end = "", wcslab will compute this quantity. +Axis2_end will be ignored if axis2_beg and axis2_int are undefined. +.le +.ls axis2_int = "" +The interval in world coordinate units at which +major grid lines / tick marks will be drawn along axis 2. +If axis2_int = "", wcslab will compute this quantity. +Axis2_int will be ignored if axis1_beg and axis1_end are undefined. +.le +.ls major_line = "solid" +The type of major grid lines to be plotted. +The permitted values are "solid", "dotted", "dashed", and "dotdash". +.le +.ls major_tick = .03 +Size of major tick marks relative to the size of the viewport. +By default the major tick marks are .03 times the size of the +viewport. +.le +.ls axis1_minor = 5 +The number of minor grid lines / tick marks that will appear between major +grid lines / tick marks for axis 1. +.le +.ls axis2_minor = 5 +The number of minor grid lines / tick marks that will appear between major +grid lines / tick marks for axis 2. +.le +.ls minor_line = "dotted" +The type of minor grid lines to be plotted. +The permitted values are "solid", "dotted", "dashed", and "dotdash". +.le +.ls minor_tick = .01 +Size of minor tick marks relative to the size of the viewport. +BY default the minor tick marks are .01 times the size of the +viewport. +.le +.ls tick_in = yes +Do tick marks point into instead of away from the graph ? +.le +.ls axis1_side = "default" +The list of viewport edges, separated by commas, on which to place the axis +1 labels. If axis1_side is "default", wcslab will choose a side. +Axis1_side may contain any combination of "left", "right", +"bottom", "top", or "default". +.le +.ls axis2_side = "default" +The list of viewport edges, separated by commas, on which to place the axis +2 labels. If axis2_side is "default", wcslab will choose a side. +Axis2_side may contain any combination of "left", "right", +"bottom", "top", or "default". +.le +.ls axis2_dir = "" +The axis 1 value at which the axis 2 labels will be written for polar graphs. +If axis2_dir is "", wcslab will compute this number. +.le +.ls justify = "default" +The direction with respect to axis 2 along which the axis 2 +labels will be drawn from the point they are labeling on polar graphs. +If justify = "", then wcslab will calculate this quantity. The permitted +values are "default", "left", "right", "top", and "bottom". +.le +.ls labout = yes +Draw the labels outside the axes ? If yes, the labels will be drawn +outside the image viewport. Otherwise, the axes labels will be drawn inside +the image border. The latter option is useful if the image fills the +display frame buffer. +.le +.ls full_label = no +Always draw all the labels in full format (h:m:s or d:m:s) if the world +coordinate system of the image is in RA and DEC ? If full_label = no, then +only certain axes will be labeled in full format. The remainder will +be labeled in minutes or seconds as appropriate. +.le +.ls rotate = yes +Permit the labels to rotate ? +If rotate = yes, then labels will be written +at an angle to match that of the major grid lines that are being +labeled. If rotate = no, then labels are always written +"normally", that is horizontally. If labout = no, then rotate is +set to "no" by default. +.le +.ls label_size = 1.0 +The size of the characters used to draw the major grid line labels. +.le +.ls title = "imtitle" +The graph title. If title = "imtitle", then a default title containing +the image name and title is created. +.le +.ls axis1_title = "" +The title for axis 1. By default no axis title is drawn. +.le +.ls axis2_title = "" +The title for axis 2. By default no axis title is drawn. +.le +.ls title_side = "top" +The side of the plot on which to place the title. +The options are "left", "right", "bottom", and "top". +.le +.ls axis1_title_side = "default" +The side of the plot on which to place the axis 1 title. +If axis1_title_side = "default", wcslab will choose a side for the title. +The permitted values are "default", "right", "left", "top", and +"bottom". +.le +.ls axis2_title_side = "default" +The side of the plot on which to place the axis 2 title. +If axis2_title_side = "default", wcslab will choose a side for the title. +The permitted values are "default", "right", "left", "top", and +"bottom". +.le +.ls title_size = 1.0 +The size of characters used to draw the title. +.le +.ls axis_title_size = 1.0 +The size of the characters used to draw the axis titles. +.le +.ls graph_type = "default" +The type of graph to be drawn. If graph_type = "default", wcslab will +choose an appropriate graph type. The permitted values are "normal", "polar", +and "near_polar". +.le + +.ih +DESCRIPTION + +WCSLAB draws a labeled world coordinate grid on the graphics device +\fIdevice\fR using world coordinate system (WCS) +information stored in the header of the IRAF image \fIimage\fR if +\fIusewcs\fR is "no", or +in \fIwcspars\fR if \fIusewcs\fR is "yes" or \fIimage\fR is "". +WCSLAB currently supports the following coordinate system types 1) +the tangent plane, sin, and arc sky projections in right ascension +and declination and 2) any linear coordinate system. + +By default WCSLAB draws on the image display device, displacing +the currently loaded image pixels with graphics pixels. Therefore in order +to register the coordinate grid plot with the image, the image must +loaded into the image display with the DISPLAY task, prior to +running WCSLAB. + +If the viewport parameters \fIvl\fR, \fIvr\fR, \fIvb\fR, and +\fIvt\fR are left undefined, WCSLAB will try to match the viewport +of the coordinate grid plot with the viewport of the currently +displayed image in the selected frame \fIframe\fR. +This scheme works well in the case where \fIimage\fR is smaller +than the display frame buffer, and in the case where \fIimage\fR is +actually a subsection of the image currently loaded into the display frame +buffer. In the case where \fIimage\fR +fills or overflows the image display frame buffer, WCSLAB +draws the appropriate coordinate grid but is not able to draw the +titles and labels which would normally appear outside the plot. +In this case the user must, either adjust the DISPLAY parameters +\fIxmag\fR, and \fIymag\fR so that the image will fit in the frame +buffer, or change the DISPLAY viewport parameters \fIxsize\fR and +\fIysize\fR so as to display only a fraction of the image. + +WCSLAB can create a new plot each time it is run, \fIappend\fR = no +and \fIoverplot\fR = no, add a new graph to an existing plot +if \fIoverplot\fR = yes and \fIappend\fR=no, +or append to an existing plot if \fIappend\fR = yes. +For new or overplots WCSLAB computes the viewport and window, otherwise it +uses the viewport and window of a previously existing plot. If \fIdevice\fR +is "stdgraph", then WCSLAB will clear the screen between each new plot. +This is not possible if \fIdevice\fR is one of the "imd" devices +since the image display graphics kernel writes directly into the display +frame buffer. In this case the user must redisplay the image and rerun +WCSLAB for each new plot. + +The parameters controlling the detailed appearance of the plot +are contained in the parameter set specified by \fIwlpars\fR. + +.ih +THE USER-DEFINED WCS + +The parameters in WCSPARS are used to define the world +coordinate system only if, 1) the parameter \fIusewcs\fR is "yes" +or, 2) the input image is undefined. +This user-defined WCS specifies the transformation from the logical coordinate +system, e.g. pixel units, to a world system, e.g. ra and dec. + +Currently IRAF supports two types of world coordinate systems: +1) linear, which provides a linear mapping from pixel units to +the world coordinate system 2) and the sky projections which provide +a mapping from pixel units to ra and dec. The parameters +\fIctype1\fR and \fIctype2\fR define which coordinate system will be in +effect. If a linear system is +desired, both \fIctype1\fR and \fIctype2\fR must be "linear". +If the tangent plane sky projection is desired, +and the first axis is ra and the +second axis is dec, then \fIcypte1\fR and \fIctype2\fR +must be "ra---tan" and "dec--tan" respectively. +To obtain the sin or arc projections "tan" is replaced with "sin" or +"arc" respectively. + +The scale factor and rotation between the logical and world coordinate +system is described by the CD matrix. Using matrix +multiplication, the logical coordinates are multiplied by the CD +matrix to produce the world coordinates. The CD matrix is represented in +the parameters as follows: + +.nf + + |---------------| + | cd1_1 cd1_2 | + | | + | cd2_1 cd2_2 | + |---------------| + +.fi + +To construct a typical CD matrix, the following definitions of the +individual matrix elements may be used: + +.nf + + cd1_1 = xscale * cos (ROT) + cd1_2 = -yscale * sin (ROT) + cd2_1 = xscale * sin (ROT) + cd2_2 = yscale * cos (ROT) + +.fi + +where xscale and yscale are the scale factors from the logical to world +systems, e.g. degrees per pixel, and ROT is the angle of rotation between +the two systems, where positive rotations are counter-clockwise. + +The ra/dec transformation is a special case. Since by convention ra +increases "to the left", opposite of standard convention, the first axis +transformation needs to be multiplied by -1. This results in the +following formulas: + +.nf + + cd1_1 = -xscale * cos (ROT) + cd1_2 = yscale * sin (ROT) + cd2_1 = xscale * sin (ROT) + cd2_2 = yscale * cos (ROT) + +.fi + +Finally, the origins of the logical and world systems must be defined. +The parameters \fIcrpix1\fR and \fIcrpix2\fR define the coordinate in +the logical space that corresponds to the coordinate in world space +defined by the parameters \fIcrval1\fR and \fIcrval2\fR. The coordinates +(crpix1, crpix2) in logical space, when transformed to world space, +become (crval1, crval2). + +The last set of parameters, log_x1, log_x2, log_y1, log_y2, define the +region in the logical space, e.g. in pixels, over which the transformation +is valid. + +.ih +AXIS SPECIFICATION + +For all \fIlinear\fR transformations axis 1 and axis 2 specify which axis in +the image is being referred to. +For example in a 2-dimensional image, the FITS image header keywords +CTYPE1, CRPIX1, CRVAL1, CDELT1, +CD1_1, and CD1_2 define the world coordinate transformation for axis 1. +Similarly the FITS image header keywords +CTYPE2, CRPIX2, CRVAL2, CDELT2, +CD2_1, CD2_2, define the world coordinate transformation for axis 2. + +THIS RULE DOES NOT APPLY TO THE TANGENT PLANE, SIN, and ARC SKY +PROJECTION WCS'S. +For this type of WCS axis 1 and axis 2 +always refer to right ascension and declination respectively, +and WCSLAB assumes that all axis 1 parameters refer to right +ascension and all axis 2 parameters refer to declination, regardless of +which axis in the image WCS actually specifies right ascension and declination. + +.ih +GRID DRAWING + +There are two types of grid lines / tick marks, "major" and +"minor". The major grid lines / tick marks are the lines / ticks +that will be labeled. The minor grid lines / tick marks are plotted +between the major marks. Whether lines or tick marks are drawn is +determined by the boolean parameters \fImajor_grid\fR and \fIminor_grid\fR. +If yes, lines are drawn; if no, tick marks are drawn. How the lines +appear is controlled by the parameters \fImajor_line\fR and \fIminor_line\fR. + +The spacing of minor marks is controlled by the parameters \fIaxis1_minor\fR +and \fIaxis2_minor\fR. These parameters specify the number of minor marks +that will appear between the major marks along the axis 1 +and axis 2 axes. + +Spacing of major marks is more complicated. WCSLAB tries to +present major marks only along "significant values" in the +coordinate system. For example, if the graph spans several hours of +right ascension, the interval between major marks will in general be an +hour and the major marks will appear at whole hours within the graph. +If what WCSLAB chooses is unacceptable, the interval and range can +be modified by the parameters \fIaxis1_int\fR, \fIaxis1_beg\fR, +\fIaxis1_end\fR for the axis 1, and \fIaxis2_int\fR, \fIaxis2_beg\fR, +and \fIaxis2_end\fR for axis 2. All three parameters must be specified for +each axis in order for the new values to take affect + +.ih +GRAPH APPEARANCE + +WCSLAB supports three types of graph: normal, polar, and near_polar. + +A normal graph is the usual Cartesian graph where lines of constant +axis 1 or 2 values cross at least two different sides of the graph. +WCSLAB will by default plot a normal type graph for any image 1) +which has no defined WCS 2) which has a linear WCS 3) where the sky +projection WCS approximates a Cartesian system. + +A polar graph is one in which the north or south pole of the +coordinate system actually appears on the graph. +Lines of constant declination are no longer approximately +straight lines, but are circles which may not intersect any +of the edges of the graph. In this type of graph, axis 1 values +are labeled all the way around the graph. +Axis 2 values are labeled within the graph +next to each circle. An attempt is made to label as many circles as +possible. However, if the WCSLAB's defaults are not agreeable, +the parameters, \fIaxis2_dir\fR and \fIjustify\fR, can be modified +to control how this labeling is done. +\fIAxis2_dir\fR specifies along which axis 1 value the +axis 2 labels should be written. \fIJustify\fR specifies on which side of +this value the label should appear. + +The near_polar graph is a cross between the normal graph and the polar +graph. In this case the pole is not on the graph, but is close enough +to significantly affect the appearance of the plot. The near_polar graph +is handled like a polar graph. + +The parameter \fIgraph_type\fR can be used to force WCSLAB +to plot a graph of the type specified, although in this case it +may be necessary to modify the values of other WLPARS parameters to +obtain pleasing results. For example trying to plot a polar graph as +Cartesian may producing a strange appearing graph. + +.ih +GRAPH LABELING + +Due to the variety of graph types that can be plotted (see above), and +the arbitrary rotation that any WCS can have, the task of labeling +the major grid lines in a coherent and pleasing manner is not trivial. + +The basic model used is the Cartesian or normal graph. Labels +normally appear on the left and bottom edges of the graph with a side +devoted solely to one of the WCS coordinate axis. For example, right +ascension might be labeled only along the bottom edge of the graph +and declination only along the left edge, or vice versa. + +If the defaults chosen by WCSLAB are unacceptable, the +parameters \fIaxis1_side\fR and \fIaxis2_side\fR, can be used to specify which +side (or sides) the labels for axis 1 and axis 2 will appear. +Either a single side or a list of sides can be specified for either +axis. If a list is specified, labels will appear on each side listed, +even if the same side appears in both of the parameters. In this way, +labels can be made to appear on the same side of the graph. + +.ih +LABEL APPEARANCE + +Due to coordinate rotations, lines of constant axis 1 or axis 2 value +may not intersect the edges +of the graph perpendicularly. To help clarify which line belongs to +which label, the labels will be drawn at an angle equal to that of the +line which is being labeled. If this is not desired, +the parameter \fIrotate\fR may be set to no, and labels will always appear +"normal", i.e. the text will not be rotated in any way. + +By default, all labels will be shortened to the smallest unit +needed to indicate the value of the labeled line. For example, if the +graph spans about 30 seconds of declination, the interval between the +labels will be approximately 5 or 10 seconds. The first label will contain the +full specification, i.e. -22:32:20. But the rest of the labels will +only be the seconds, i.e. 30, 40, 50. However, at the change in +minutes, the full format would be used again, -22:33:00, but then +again afterwards only seconds will be displayed, i.e. 10, 20, etc. +If this shortening of labels is undesirable, it +can be turned off by setting the parameter \fIfull_label\fR to yes. This +forces every label to use the full specification. + +Finally, the parameter \fIlabel_size\fR can be used to adjust the size of the +characters used in the axis labels. + +.ih +TITLES + +A graph title may specified using the parameter \fItitle\fR. If \fItitle\fR += "imtitle" a default title constructed from the image name and title +is used. The location and size of the graph title are controlled by +the parameters \fItitle_side\fR and \fItitle_size\fR. +Similarly the content, placement and size of the axis titles are +controlled by the parameters \fIaxis1_title\fR, \fIaxis2_title\fR, +\fIaxis1_title_side\fR, \fIaxis2_title_side\fR, and +\fIaxis_title_size\fR. + +.ih +OUTPUT FORMATS + +If \fIremember\fR = yes, the coordinates are output to the parameter set +WLPARS in a form suitable for the type of system the coordinates +represent. For example right +ascensions are output in HH:MM:SS (hours:minutes:seconds) and +declinations are output in DD:MM:SS (degrees:minutes:seconds). +If the input parameters are changed, for example axis1_int, their values +must be input in the same format. +If the WCS is linear, then the parameters will not be formatted in any special +way; i.e. no assumptions are made about units, etc. + +.ih +EXAMPLES + +1. Display the 512 pixel square IRAF test image dev$pix in an 800 square +display window and overlay it with a labeled coordinate grid. Since +dev$pix does not have a defined WCS a pixel coordinate grid will appear. + +.nf + cl> display dev$pix 1 + + ... display the image in frame 1 + + cl> wcslab dev$pix 1 + + ... the coordinate grid in green will be plotted on the display +.fi + +2. Redisplay the previous image and by overlay the labeled +coordinate grid on the inner 100 by 400 pixels in x and y. + +.nf + cl> display dev$pix 1 + + ... erase the graphics by redisplaying the image + + cl> wcslab dev$pix[100:400,100:400] 1 +.fi + +3. Display an 800 square image which has a defined linear WCS in an 800 square +display window and overlay it with the coordinate grid. Reduce +the display viewport in order to leave space around the edge of the +displayed image for the labels and titles. + +.nf + cl> display image 1 xsize=0.8 ysize=0.8 fill+ + cl> wcslab image 1 vl=.1 vr=.9 vb=.1 vt=.9 +.fi + +4. Repeat the previous example using a different combination of display +and wcslab parameters to achieve the same goal. + +.nf + cl> display image 1 xmag=0.8 ymag=0.8 + cl> wcslab image 1 +.fi + +5. Display a section of the previous image and overlay it with a +coordinate grid. Note that the same section should be specified in +both cases. + +.nf + cl> display image[101:700,101:700] 1 + cl> wcslab image[101:700,101:700] 1 +.fi + +6. Display a 512 square image with a defined tangent plane sky projection +in an 800 square frame buffer and overlay the labeled coordinate grid. The +standard FITS keywords shown below define the WCS. This WCS is +approximately correct for the IRAF test image dev$pix. + +.nf + # IRAF image header keywords which define the WCS + + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 201.94541667302 # RA is stored in degrees ! + CRVAL2 = 47.45444 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + CDELT1 = -2.1277777E-4 + CDELT2 = 2.1277777E-4 + + + cl> display dev$pix 1 + + cl> wcslab dev$pix 1 +.fi + +7. Display a 512 square image with a defined tangent plane sky projection +approximately centered on the north celestial pole in an 800 square frame +buffer. The FITS keywords shown below define the WCS. + + +.nf + # IRAF image header keywords which define the WCS + + CRPIX1 = 257.75 + CRPIX2 = 258.93 + CRVAL1 = 201.94541667302 # RA is stored in degrees ! + CRVAL2 = 90.00000 + CTYPE1 = 'RA---TAN' + CTYPE2 = 'DEC--TAN' + CDELT1 = -2.1277777E-4 + CDELT2 = 2.1277777E-4 + + cl> display northpole 1 + + cl> wcslab northpole 1 +.fi + +8. Display and label a 512 square image which has no WCS information +using the values of the parameters in wcspars. The center pixel (256.0, 256.0) +is located at (9h 22m 30.5s, -15o 05m 42s), the pixels are .10 +arcseconds in size, and are rotated 30.0 degrees counter-clockwise. + +.nf + + cl> lpar wcspars + + ctype1 = 'ra---tan' + ctype2 = 'dec--tan' + crpix1 = 256.0 + crpix2 = 256.0 + crval1 = 140.62708 + crval2 = -15.09500 + cd1_1 = -2.405626e-5 + cd1_2 = 1.388889e-5 + cd2_1 = 1.388889e-5 + cd2_2 = 2.405626e-5 + log_x1 = 1. + log_x2 = 512. + log_y1 = 1. + log_y2 = 512. + + cl> display image 1 + + cl> wcslab image usewcs+ + +.fi +.ih +AUTHORS +The WCSLAB task was written by members of the STScI SDAS programming group +and integrated into the IRAF DISPLAY package by members of the IRAF +programming group for version 2.10 IRAF. +.ih +SEE ALSO +display, gcur, imdkern +.endhelp diff --git a/pkg/images/tv/eimexam.par b/pkg/images/tv/eimexam.par new file mode 100644 index 00000000..a67e4322 --- /dev/null +++ b/pkg/images/tv/eimexam.par @@ -0,0 +1,24 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"Column",,,"X-axis label" +ylabel,s,h,"Line",,,"Y-axis label" + +ncolumns,i,h,21,2,,Number of columns +nlines,i,h,21,2,,Number of lines +floor,r,h,INDEF,,,"minimum value to be contoured (0 if none)" +ceiling,r,h,INDEF,,,"maximum value to be contoured (0 if none)" +zero,r,h,0.,,,"greyscale value of zero contour" +ncontours,i,h,5,,,"number of contours to be drawn (0 for default)" +interval,r,h,0.,,,"contour interval (0 for default)" +nhi,i,h,-1,,,"hi/low marking option: -1=omit, 0=mark h/l, 1=mark each pix" +dashpat,i,h,528,,,"bit pattern for generating dashed lines" +label,b,h,no,,,"label major contours with their values?" + +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? +fill,b,h,no,,,fill viewport vs enforce unity aspect ratio? diff --git a/pkg/images/tv/himexam.par b/pkg/images/tv/himexam.par new file mode 100644 index 00000000..7a35a911 --- /dev/null +++ b/pkg/images/tv/himexam.par @@ -0,0 +1,29 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"Pixel Bin",,,"X-axis label" +ylabel,s,h,"Count",,,"Y-axis label" + +ncolumns,i,h,21,2,,Number of columns +nlines,i,h,21,2,,Number of lines +nbins,i,h,512,1,,Number of bins in histogram +z1,r,h,INDEF,,,Minimum histogram intensity +z2,r,h,INDEF,,,Maximum histogram intensity +autoscale,b,h,yes,,,Adjust nbins and z2 for integer data? +top_closed,b,h,no,,,Include z2 in the top bin? + +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,0.,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,no,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,yes,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/iis/README b/pkg/images/tv/iis/README new file mode 100644 index 00000000..1562fd6f --- /dev/null +++ b/pkg/images/tv/iis/README @@ -0,0 +1,3 @@ +CV -- Control video package. This is a prototype package, used to load images +into the image display (currently only the IIS), as well as to control the +display and read the display memory. diff --git a/pkg/images/tv/iis/blink.cl b/pkg/images/tv/iis/blink.cl new file mode 100644 index 00000000..5cc437e5 --- /dev/null +++ b/pkg/images/tv/iis/blink.cl @@ -0,0 +1,19 @@ +#{ BLINK -- Blink 2, 3, or 4 frames. + +# frame1,i,a,,,,Frame1 +# frame2,i,a,,,,Frame2 +# frame3,i,a,,,,Frame3 +# frame4,i,a,,,,Frame4 +# rate,r,h,1.,,,Blink rate (sec per frame) + +{ + if ($nargs == 3) { + _dcontrol (alternate = frame1 // " " // frame2 // " " // + frame3, blink+, rate=rate) + } else if ($nargs == 4) { + _dcontrol (alternate = frame1 // " " // frame2 // " " // + frame3 // " " // frame4, blink+, rate=rate) + } else { + _dcontrol (alternate = frame1 // " " // frame2, blink+, rate=rate) + } +} diff --git a/pkg/images/tv/iis/blink.par b/pkg/images/tv/iis/blink.par new file mode 100644 index 00000000..bccfa8f2 --- /dev/null +++ b/pkg/images/tv/iis/blink.par @@ -0,0 +1,5 @@ +frame1,i,a,,,,Frame1 +frame2,i,a,,,,Frame2 +frame3,i,a,,,,Frame3 +frame4,i,a,,,,Frame4 +rate,r,h,1.,,,Blink rate (sec per frame) diff --git a/pkg/images/tv/iis/cv.par b/pkg/images/tv/iis/cv.par new file mode 100644 index 00000000..c33dd032 --- /dev/null +++ b/pkg/images/tv/iis/cv.par @@ -0,0 +1,4 @@ +# Package parameters for CV. + +snap_file,f,a,,,,output file for snap image +textsize,r,a,1.0,,,character size diff --git a/pkg/images/tv/iis/cvl.par b/pkg/images/tv/iis/cvl.par new file mode 100644 index 00000000..c2eb9fab --- /dev/null +++ b/pkg/images/tv/iis/cvl.par @@ -0,0 +1,25 @@ +# Package parameters for CVL. +# All are from "display.par" + +image,f,a,,,,image to be displayed +frame,i,a,1,1,4,frame to be written into +border_erase,b,h,no,,,erase unfilled area of window +erase,b,h,yes,,,display frame being loaded +select_frame,b,h,yes,,,display frame being loaded +#repeat,b,h,no,,,repeat previous display parameters +fill,b,h,no,,,scale image to fit display window +zscale,b,h,yes,,,display range of greylevels near median +contrast,r,h,0.25,,,contrast adjustment for zscale algorithm +zrange,b,h,yes,,,display full image intensity range +nsample_lines,i,h,5,,,number of sample lines +xcenter,r,h,0.5,0,1,display window horizontal center +ycenter,r,h,0.5,0,1,display window vertical center +xsize,r,h,1,0,1,display window horizontal size +ysize,r,h,1,0,1,display window vertical size +xmag,r,h,1.,,,display window horizontal magnification +ymag,r,h,1.,,,display window vertical magnification +z1,r,h,,,,minimum greylevel to be displayed +z2,r,h,,,,maximum greylevel to be displayed +ztrans,s,h,linear,,,greylevel transformation (linear|log|none) +lutfile,f,h,"",,,name of textfile with user's transformation table +version,s,h,"14May85" diff --git a/pkg/images/tv/iis/doc/Cv.spc.hlp b/pkg/images/tv/iis/doc/Cv.spc.hlp new file mode 100644 index 00000000..0b30ae1c --- /dev/null +++ b/pkg/images/tv/iis/doc/Cv.spc.hlp @@ -0,0 +1,286 @@ +.help cv Jan86 tv.cv +The \fIcv\fR program is used to control the image display from within +\fIIRAF\fR. It differs from most \fIIRAF\fR programs since it has its +own prompt and its own internal "language". Each of the available commands +is described in the following paragraphs, but first a few comments on the +command structure seem in order. Commands are distinguished by their +first letter, except for a few instances where the second letter is needed. +The rest of the command name can be typed if you wish. Commands often +require specification of frames numbers, colors, quadrants, or numeric +values. In most cases, the order is unimportant, but, zoom, for instance, +does require the zoom power right after the command name. The order given +in the \fIhelp\fR command will always work. + +A frame list is indicated in the \fIhelp\fR listing with an \fBF\fR. This +is to be replaced in the typed command by an \fBf\fR followed (no spaces) +with a list of the pertinent image planes. Thus, \fBf1\fR means +\fIframe 1\fR while \fBf42\fR means \fIframes 4\fR +and \fI2\fR. In most cases, the leading \fBf\fR can be omitted. +The specification \fBfa\fR means \fIall frames\fR. In those +cases in the \fIhelp\fR menu where the frame specification is optional, +omitting the frame list is the same as typing \fBfa\fR; that is, operate +on \fIall\fR frames. + +A color specification is a \fBc\fR followed by a set of letters. +The letter \fBa\fR means \fIall\fR, just as in the frame specification. +The letters \fBr, b,\fR and \fBg\fR are the other possibilities for all +commands other than \fIdg\fR and \fIsnap\fR. For displaying graphics +planes (\fBdg\fR), the other possibilities are \fBy, p, m, w\fR which +stand for \fIyellow, purple, mauve,\fR and \fIwhite\fR. (\fIMauve\fR is +the wrong name and will get changed.) The \fIsnap\fR command accepts, in +addition to the standard three colors, \fBm, bw,\fR and \fBrgb\fR, which +stand for \fImonochrome, black and white,\fR and \fIfull color\fR. (See +the discussion under \fIsnap\fR for further explanation.) +An omitted color specification is the same as \fIall colors\fR. + +Quadrants are given by a \fBq\fR followed by numbers from the set one through +four, or the letter \fBa\fR as in the frame and color cases. Quadrants are +numbered in the standard way, with the upper right being \fI1\fR, the upper +left \fI2\fR, etc. Adjacent quadrants may be referenced by \fBt, b, l,\fR +and \fBr\fR, standing for \fItop, bottom, left,\fR and \fIright\fR. An +omitted quadrant specification is the same as \fIall quadrants\fR. Quadrants +are effective only if the split screen command has set the split point to +something other than the "origin". + +.ls \fBblink\fR N F (C Q) (F C Q) +The blink rate is given by \fBN\fR, which is in tenths of a second. Although +current timing routines in \fIIRAF\fR do not recognize partial seconds, +for the NOAO 4.2BSD UNIX implementation, a non-portable timing routine is +used so that tenth seconds are usable. +Erratic timing is pretty much the rule when the system load is large. +One frame must be given, +followed by any color or quadrant specification, and then +optionally followed by any number of similar triads. A specification of +\fI10 f12 f3 f3 f4\fR would display frames one and two for one second, then +frame three for two one second intervals, then frame 4, and then recycle. +The first blink cycle may appear somewhat odd as the code "settles in", +but the sequence should become regular after that (except for timing +problems due to system load). In split screen mode, it is necessary to +specify all the frames together with quadrants, which leads to a lot of +typing: The reason is that blink simply cycles through a series of +\fBdi\fR commands, and hence it requires the same information as that +command. +.le +.ls \fBcursor\fR [on off F] +This command is used to turn the cursor on or off, and to read coordinates +and pixel values from a frame. Pixel coordinates for a feature are those +of the image as loaded into the display, and do not change as the image +is panned or zoomed. Fractional pixel positions are given for zoomed +images, with a minimum number of decimal places printed (but the same number +for both the \fIx\fR and \fIy\fR coordinates). +For an unpanned, unzoomed image plane, the lower left corner +of the \fIscreen\fR is (1,1) +even if the image you loaded is smaller than 512x512, occupies only +a portion of the display screen, and does not extend to the lower left +corner of the screen. This defect will likely be remedied +when the \fIcv\fR package is properly integrated into \fIIRAF\fR. +Pixel information can be read from a frame that is not being displayed. +.le +.ls \fBdi\fR F (C Q) [on off] +The \fId\fRisplay \fIi\fRmage command turns specified frames on (or off). +Turning a frame off does not erase it. A frame need not have all colors +turned on, nor appear in all quadrants of a split screen display. +.le +.ls \fBdg\fR C (F Q) [on off] +The \fId\fRisplay \fIg\fRraphics command turns specific graphics planes +on or off. For the IIS display, neither the frame nor the quadrant +parameters are relevant. A side-effect of this command is that it +resets the graphics hardware to the \fIcv\fR standard: red cursor and +seven graphics planes, each colored differently. If the display is in +a "weird" state that is not cured with the \fIreset r/t\fR commands, +and a \fIreset i\fR would destroy images of interest, try a \fIdg ca on\fR +command followed by \fIdg ca off\fR. +.le +.ls \fBerase\fR [F all graphics] +This command erases the specified frame, or all the graphics planes, or +all data planes. The command \fBclear\fR is a synonym. +.le +.ls \fBmatch\fR (o) (F) (C) (to) (F) (C) +This command allows the user to copy a look-up table to a specified set +of tables, and hence, to match the mapping function of frames (and/or +colors) to a reference table. If the \fBo\fR parameter is omitted, the +match is among the look-up tables associated with particular frames; +otherwise, the \fIouput\fR tables are used (hence, the \fBo\fR). In the +latter case, only colors are important; the frame information should +be omitted. For the individual frame tables, colors can be omitted, in +which case a match of frame one to two means to copy the three tables +of frame two (red, green, and blue) to those of frame one. Only one +reference frame or color should be given, but \fImatch f23 cgb f1 cr\fR +is legal and means to match the green and blue color tables of both +frames two and three to the red table of frame one. +.le +.ls \fBoffset\fR C N +The value N, which can range from -4095 to +4095 is added to the data +pipeline for color \fBC\fR, thus offsetting the data. This is useful +if one needs to change the data range that is mapped into the useful part +of the output tables. +.le +.ls \fBpan\fR (F) +When invoked, this command connects the trackball to the specified frames +and allows the user to move (pan/roam/scroll) the image about the screen. +This function is automatically invoked whenever the zoom factor is changed. +.le +.ls \fBpseudo\fR (o) (F C) (rn sn) +Look-up tables are changed with the \fIwindow\fR and the \fIpseudocolor\fR +commands. Windowing provides linear functions and is discussed under that +command; \fIpseudo\fR provides pseudo-coloring capabilities. Pseudo-color +maps are usually best done in the output tables, rather than in the +look-up tables associated with particular frames; hence, \fBps o\fR is +the more likely invocation of the start of the command line. A color +(or colors) can be specified for "output" pseudocolor, in which case, only +those colors will be affected. For frame look-up tables, +the frame must be specified. + +Two mappings are provided. One uses a set of randomly selected colors +mapped to a specified number of pixel value ranges. The other uses +triangle color mappings. The former is invoked with the \fI(rn sn)\fR +options. In this case, the number following \fBr\fR gives the number of +ranges/levels into which the input data range is to be divided; to +each such range, a randomly selected color is assigned. The number +following \fBs\fR is a seed for the random number generator; changing +this while using the same number of levels gives different color mappings. +The default seed is the number of levels. If only the seed is given (\fBr\fR +omitted), the default number of levels is 8. This mapping is used when +a contour type display is desired: each color represents an intensity range +whose width is inversely proportional to the number of levels. + +The triangle mapping uses a different triangle in each of the three look-up +tables (either the sets associated with the specified frames, or the output +tables). The initial tables map low intensity to blue, middle values to +green, and high values to red, as shown in the diagram. (The red and blue +triangles are truncated as their centers are on a table boundary.) + +Once invoked, the program then allows the user to adjust the triangle +mapping. In +response to the prompt line, select the color to be changed and move the +trackball: the center of the triangle is given by the \fIx\fR cursor +coordinate and the width by the \fIy\fR coordinate. Narrow functions +(small \fIy\fR) allow one to map colors to a limited range of intensity. +When the mapping is satisfactory, a press of any button "fixes" the +mapping and the user may then either select another color or exit. +Before selecting a color, place the cursor at approximately the default +position for the mapping (or where it was for the last mapping of that +color under the current command); otherwise, the color map will change +suddenly when the color is selected via the trackball buttons. +.le +.ls \fBrange\fR N (C) (N C ...) +This command changes the range function in the specified color pipeline +so that the data is scaled by (divided by) the value \fBN\fR. For the +IIS, useful range values are 1,2,4 and 8; anything else will be changed +to the next lowest legal value. +.le +.ls \fBreset\fR [r i t a] +Various registers and tables are reset with this command. If the \fBr\fR +option is used, the registers are reset. This means that zoom is set to +one, all images are centered, split screen is removed, the range values are +set to one and the offset values are set to zero. Also, the cursor is +turned on and its shape is set. Option \fBi\fR causes all the image and +graphics planes to be erased and turned off. Option \fBt\fR resets all +the look-up tables to their default linear, positive slope, form, and +removes any color mappings by making all the output tables the same, and +all the frame specific tables the same. Option \fBa\fR does \fIall\fR +the above. +.le +.ls \fBsnap\fR (C) +This command creates an \fIIRAF\fR image file whose contents are a +512x512 digital snapshot of the image display screen. If no color +is specified, +or if \fIcm\fR (color monochromatic) is given, +the snapshot is of the \fIblue\fR image, which, if you +have a black and white image, is the same as the red or the green +image. Specifying \fBcg\fR for instance will take a snapshot of the +image that you would get had you specified \fIcg\fR for each frame +turned on by the \fIdi\fR command. Color is of interest only when +the window or pseudo color commands have made the three colors distinguishable. +If the "snapped" image is intended to be fed to the Dicomed film +recorder, a black and white image is all that is usually provided and so +a color snap is probably not appropriate. +In the case of the "no color/monochromatic" snap, the graphics planes are +all added together, while, if a real color is given, only the graphics +planes that have some of that color are included in the image. +The color \fBrgb\fR can be +given, in which case the red, green, and blue images are weighted equally +to produce a single image file. This image does not represent well what +you see, partly because of the equal weight given all colors: some +mapping of eye sensitivity is probably what is required, but it is not +implemented. + +The program operates by first determining zoom, pan, offset, tables, etc, +and, for each quadrant of the split screen, which images planes are active. +Then, for each line of the display, those images are read out from the display's +memory and the transformations done in hardware are duplicated pixel by pixel +in software. The word "active" needs a bit of explanation. Any image plane +whose pixels are contributing to the image is active. No image is active if +it has been turned off (by the \fIdi\fR) command (or if all images were +turned off and the one of interest not subsequently turned back on). If the +image is all zeroes, or if it is not but split screen is active and the +part of the image being displayed is all zeroes, it is not contributing to +the output. However, the snap program cannot tell that an active image is +not contributing anything useful, +and so it dutifully reads out each pixel and adds zeroes to the output. +The moral of this is that frames of no interest should be (turned) off before +snap is called (unless you don't have anything better to do than wait for +computer prompts). When split screen is active, frames are read only for +the quadrants in which they are active. + +The fastest snaps are for single images that are zoomed but not panned +and which are displayed (and snapped) in black and white, or snapped +in a single color. +.le +.ls \fBsplit\fR [c o px,y nx,y] +This command sets the split screen point. Option \fBc\fR is shorthand for +\fIcenter\fR, which is the normal selection. Option \fBo\fR stands for +\fIorigin\fR, and is the split position that corresponds to no split screen. +If you wish to specify the split point in pixels, use the \fBpx,y\fR form, in +which the coordinates are given as integers. If you prefer to specify +the point in NDC (which range from 0 though 1.0), use the \fBnx,y\fR form +in which the coordinates are decimal fractions. + +A peculiarity of the IIS hardware is that if no split screen is desired, +the split point must be moved to the upper left corner of the display, rather +than to the lower left (the \fIIRAF\fR 1,1 position). This means that no +split screen (the \fBo\fR option, or what you get after \fBre r\fR) is really +split screen with only quadrant \fBfour\fR displayed: if you use the \fIdi\fR +command with quadrant specification, only quadrant 4 data will be seen. +.le +.ls \fBtell\fR +This command displays what little it knows about the display status. At +present, all it can say is whether any image plane is being displayed, and +if any are, what is the number of one of them. This rather weak performance +is the result of various design decisions both within \fIcv\fR and the +\fIIRAF\fR display code, and may be improved. +.le +.ls \fBwindow\fR (o) (F C) +This command operates just as the \fIpseudo\fR command, except that it +applies a linear mapping to the output look-up tables (if option \fBo\fR +is used) or to the frame specific tables. The mapping is controlled by +the trackball, with the \fIy\fR cursor coordinate supplying the slope +of the map, and \fIx\fR the offset. If different mappings are given to +each color, a form of pseudo-color is generated. +.le +.ls \fBwrite\fR [F C] text +This command writes the given text into either an image plane (or planes) +or into the specified color graphics bit plane(s). The user is prompted +to place the cursor at the (lower left) corner of the text, which is +then written to the right in roman font. The user is also asked for +a text size (default 1.0). If the text is written into a graphics +plane, and a \fBsnap\fR is requested with no color specification, then +text in any graphics plane will be included in the image. A color snap, +on the other hand, will include graphics text to the extent that the +text is displayed in that color. +Text written into an image plane +will have the same appearance as any "full on" pixel; that is, text +in an image plane is written at maximum intensity, +overwrites the image data, +and is affected by look-up tables, offsets, +and so forth, like any other image pixels. +.le +.ls \fBzoom\fR N (F) +This command zooms the display to the power given by \fBN\fR. For the +IIS, the power must be 1,2,4, or 8; anything else is changed to the next +lower legal value. The model 70 zooms all planes together. The center +of the zoom is determined by the cursor position relative to the first +frame specified (if none, the lowest numbered active one). Once the zoom +has taken place, the \fIpan\fR routine is called for the specified frames. +.le +.endhelp diff --git a/pkg/images/tv/iis/doc/blink.hlp b/pkg/images/tv/iis/doc/blink.hlp new file mode 100644 index 00000000..f1440ebf --- /dev/null +++ b/pkg/images/tv/iis/doc/blink.hlp @@ -0,0 +1,46 @@ +.help blink Jan86 images.tv.iis +.ih +NAME +blink -- Blink frames in the image display +.ih +USAGE +blink frame1 frame2 [frame3 [frame4]] +.ih +PARAMETERS +.ls frame1 +First frame in blink sequence. +.le +.ls frame2 +Second frame in blink sequence. +.le +.ls frame3 +Third frame in blink sequence. +.le +.ls frame4 +Fourth frame in blink sequence. +.le +.ls rate = 1. +Blink rate in seconds per frame. May be any fraction of a second. +.le +.ih +DESCRIPTION +Two or more frames are alternately displayed on the image display monitor +("stdimage") at a specified rate per frame. +.ih +EXAMPLES +To blink two frames: + + cl> blink 1 2 + +To blink three frames at a rate of 2 seconds per frame: + + cl> blink 3 1 2 rate=2 +.ih +BUGS +The blink rate is measured in +software and, therefore, will not be exactly even in a time sharing +environment. +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/cv.doc b/pkg/images/tv/iis/doc/cv.doc new file mode 100644 index 00000000..d34ccaa0 --- /dev/null +++ b/pkg/images/tv/iis/doc/cv.doc @@ -0,0 +1,332 @@ +.TL +The "cv" Display Package +.AU +Richard Wolff +.DA +.PP +The \fIcv\fR program is used to control the image display from within +\fIIRAF\fR. It differs from most \fIIRAF\fR programs since it has its +own prompt and its own internal "language". Each of the available commands +is described in the following paragraphs, but first a few comments on the +command structure seem in order. Commands are distinguished by their +first letter, except for a few instances where the second letter is needed. +The rest of the command name can be typed if you wish. Commands often +require specification of frames numbers, colors, quadrants, or numeric +values. In most cases, the order is unimportant, but, zoom, for instance, +does require the zoom power right after the command name. The order given +in the \fIhelp\fR command will always work. +.PP +A frame list is indicated in the \fIhelp\fR listing with an \fBF\fR. This +is to be replaced in the typed command by an \fBf\fR followed (no spaces) +with a list of the pertinent image planes. Thus, \fBf1\fR means +.I "frame 1" +while \fBf42\fR means +.I "frames 4" +and \fI2\fR. In most cases, the leading \fBf\fR can be omitted. +The specification \fBfa\fR means \fIall frames\fR. In those +cases in the \fIhelp\fR menu where the frame specification is optional, +omitting the frame list is the same as typing \fBfa\fR; that is, operate +on \fIall\fR frames. +.PP +A color specification is a \fBc\fR followed by a set of letters. +The letter \fBa\fR means \fIall\fR, just as in the frame specification. +The letters \fBr, b,\fR and \fBg\fR are the other possibilities for all +commands other than \fIdg\fR and \fIsnap\fR. For displaying graphics +planes (\fBdg\fR), the other possibilities are \fBy, p, m, w\fR which +stand for \fIyellow, purple, mauve,\fR and \fIwhite\fR. (\fIMauve\fR is +the wrong name and will get changed.) The \fIsnap\fR command accepts, in +addition to the standard three colors, \fBm, bw,\fR and \fBrgb\fR, which +stand for \fImonochrome, black and white,\fR and \fIfull color\fR. (See +the discussion under \fIsnap\fR for further explanation.) +An omitted color specification is the same as \fIall colors\fR. +.PP +Quadrants are given by a \fBq\fR followed by numbers from the set one through +four, or the letter \fBa\fR as in the frame and color cases. Quadrants are +numbered in the standard way, with the upper right being \fI1\fR, the upper +left \fI2\fR, etc. Adjacent quadrants may be referenced by \fBt, b, l,\fR +and \fBr\fR, standing for \fItop, bottom, left,\fR and \fIright\fR. An +omitted quadrant specification is the same as \fIall quadrants\fR. Quadrants +are effective only if the split screen command has set the split point to +something other than the "origin". +.sp +.SH +\fBblink\fR N F (C Q) (F C Q) +.IP +The blink rate is given by \fBN\fR, which is in tenths of a second. Although +current timing routines in \fIIRAF\fR do not recognize partial seconds, +for the NOAO 4.2BSD UNIX implementation, a non-portable timing routine is +used so that tenth seconds are usable. +Erratic timing is pretty much the rule when the system load is large. +One frame must be given, +followed by any color or quadrant specification, and then +optionally followed by any number of similar triads. A specification of +\fI10 f12 f3 f3 f4\fR would display frames one and two for one second, then +frame three for two one second intervals, then frame 4, and then recycle. +The first blink cycle may appear somewhat odd as the code "settles in", +but the sequence should become regular after that (except for timing +problems due to system load). In split screen mode, it is necessary to +specify all the frames together with quadrants, which leads to a lot of +typing: The reason is that blink simply cycles through a series of +\fBdi\fR commands, and hence it requires the same information as that +command. +.SH +\fBcursor\fR [on off F] +.IP +This command is used to turn the cursor on or off, and to read coordinates +and pixel values from a frame. Pixel coordinates for a feature are those +of the image as loaded into the display, and do not change as the image +is panned or zoomed. Fractional pixel positions are given for zoomed +images, with a minimum number of decimal places printed (but the same number +for both the \fIx\fR and \fIy\fR coordinates). +For an unpanned, unzoomed image plane, the lower left corner +of the \fIscreen\fR is (1,1) +even if the image you loaded is smaller than 512x512, occupies only +a portion of the display screen, and does not extend to the lower left +corner of the screen. This defect will likely be remedied +when the \fIcv\fR package is properly integrated into \fIIRAF\fR. +Pixel information can be read from a frame that is not being displayed. +.SH +\fBdi\fR F (C Q) [on off] +.IP +The \fId\fRisplay \fIi\fRmage command turns specified frames on (or off). +Turning a frame off does not erase it. A frame need not have all colors +turned on, nor appear in all quadrants of a split screen display. +.SH +\fBdg\fR C (F Q) [on off] +.IP +The \fId\fRisplay \fIg\fRraphics command turns specific graphics planes +on or off. For the IIS display, neither the frame nor the quadrant +parameters are relevant. A side-effect of this command is that it +resets the graphics hardware to the \fIcv\fR standard: red cursor and +seven graphics planes, each colored differently. If the display is in +a "weird" state that is not cured with the \fIreset r/t\fR commands, +and a \fIreset i\fR would destroy images of interest, try a \fIdg ca on\fR +command followed by \fIdg ca off\fR. +.SH +\fBerase\fR [F all graphics] +.IP +This command erases the specified frame, or all the graphics planes, or +all data planes. The command \fBclear\fR is a synonym. +.SH +\fBmatch\fR (o) (F) (C) (to) (F) (C) +.IP +This command allows the user to copy a look-up table to a specified set +of tables, and hence, to match the mapping function of frames (and/or +colors) to a reference table. If the \fBo\fR parameter is omitted, the +match is among the look-up tables associated with particular frames; +otherwise, the \fIouput\fR tables are used (hence, the \fBo\fR). In the +latter case, only colors are important; the frame information should +be omitted. For the individual frame tables, colors can be omitted, in +which case a match of frame one to two means to copy the three tables +of frame two (red, green, and blue) to those of frame one. Only one +reference frame or color should be given, but \fImatch f23 cgb f1 cr\fR +is legal and means to match the green and blue color tables of both +frames two and three to the red table of frame one. +.SH +\fBoffset\fR C N +.IP +The value N, which can range from -4095 to +4095 is added to the data +pipeline for color \fBC\fR, thus offsetting the data. This is useful +if one needs to change the data range that is mapped into the useful part +of the output tables. +.SH +\fBpan\fR (F) +.IP +When invoked, this command connects the trackball to the specified frames +and allows the user to move (pan/roam/scroll) the image about the screen. +This function is automatically invoked whenever the zoom factor is changed. +.SH +\fBpseudo\fR (o) (F C) (rn sn) +.IP +Look-up tables are changed with the \fIwindow\fR and the \fIpseudocolor\fR +commands. Windowing provides linear functions and is discussed under that +command; \fIpseudo\fR provides pseudo-coloring capabilities. Pseudo-color +maps are usually best done in the output tables, rather than in the +look-up tables associated with particular frames; hence, \fBps o\fR is +the more likely invocation of the start of the command line. A color +(or colors) can be specified for "output" pseudocolor, in which case, only +those colors will be affected. For frame look-up tables, +the frame must be specified. +.IP +Two mappings are provided. One uses a set of randomly selected colors +mapped to a specified number of pixel value ranges. The other uses +triangle color mappings. The former is invoked with the \fI(rn sn)\fR +options. In this case, the number following \fBr\fR gives the number of +ranges/levels into which the input data range is to be divided; to +each such range, a randomly selected color is assigned. The number +following \fBs\fR is a seed for the random number generator; changing +this while using the same number of levels gives different color mappings. +The default seed is the number of levels. If only the seed is given (\fBr\fR +omitted), the default number of levels is 8. This mapping is used when +a contour type display is desired: each color represents an intensity range +whose width is inversely proportional to the number of levels. +.IP +The triangle mapping uses a different triangle in each of the three look-up +tables (either the sets associated with the specified frames, or the output +tables). The initial tables map low intensity to blue, middle values to +green, and high values to red, as shown in the diagram. (The red and blue +triangles are truncated as their centers are on a table boundary.) +.sp +.KS +.PS +B: box +move +G: box +move +R: box +move to B.sw left 0.375 +line dotted to B.nw +line dashed to B.s +move to G.sw +line dashed to G.n +line dashed to G.se +move to R.s +line dashed to R.ne +line dotted to R.se right 0.375 +"blue" at B.s below +"green" at G.s below +"red" at R.s below +.PE +.sp +.KE +.IP +Once invoked, the program then allows the user to adjust the triangle +mapping. In +response to the prompt line, select the color to be changed and move the +trackball: the center of the triangle is given by the \fIx\fR cursor +coordinate and the width by the \fIy\fR coordinate. Narrow functions +(small \fIy\fR) allow one to map colors to a limited range of intensity. +When the mapping is satisfactory, a press of any button "fixes" the +mapping and the user may then either select another color or exit. +Before selecting a color, place the cursor at approximately the default +position for the mapping (or where it was for the last mapping of that +color under the current command); otherwise, the color map will change +suddenly when the color is selected via the trackball buttons. +.SH +\fBrange\fR N (C) (N C ...) +.IP +This command changes the range function in the specified color pipeline +so that the data is scaled by (divided by) the value \fBN\fR. For the +IIS, useful range values are 1,2,4 and 8; anything else will be changed +to the next lowest legal value. +.SH +\fBreset\fR [r i t a] +.IP +Various registers and tables are reset with this command. If the \fBr\fR +option is used, the registers are reset. This means that zoom is set to +one, all images are centered, split screen is removed, the range values are +set to one and the offset values are set to zero. Also, the cursor is +turned on and its shape is set. Option \fBi\fR causes all the image and +graphics planes to be erased and turned off. Option \fBt\fR resets all +the look-up tables to their default linear, positive slope, form, and +removes any color mappings by making all the output tables the same, and +all the frame specific tables the same. Option \fBa\fR does \fIall\fR +the above. +.SH +\fBsnap\fR (C) +.IP +This command creates an \fIIRAF\fR image file whose contents are a +512x512 digital snapshot of the image display screen. If no color +is specified, +or if \fIcm\fR (color monochromatic) is given, +the snapshot is of the \fIblue\fR image, which, if you +have a black and white image, is the same as the red or the green +image. Specifying \fBcg\fR for instance will take a snapshot of the +image that you would get had you specified \fIcg\fR for each frame +turned on by the \fIdi\fR command. Color is of interest only when +the window or pseudo color commands have made the three colors distinguishable. +If the "snapped" image is intended to be fed to the Dicomed film +recorder, a black and white image is all that is usually provided and so +a color snap is probably not appropriate. +In the case of the "no color/monochromatic" snap, the graphics planes are +all added together, while, if a real color is given, only the graphics +planes that have some of that color are included in the image. +The color \fBrgb\fR can be +given, in which case the red, green, and blue images are weighted equally +to produce a single image file. This image does not represent well what +you see, partly because of the equal weight given all colors: some +mapping of eye sensitivity is probably what is required, but it is not +implemented. +.IP +The program operates by first determining zoom, pan, offset, tables, etc, +and, for each quadrant of the split screen, which images planes are active. +Then, for each line of the display, those images are read out from the display's +memory and the transformations done in hardware are duplicated pixel by pixel +in software. The word "active" needs a bit of explanation. Any image plane +whose pixels are contributing to the image is active. No image is active if +it has been turned off (by the \fIdi\fR) command (or if all images were +turned off and the one of interest not subsequently turned back on). If the +image is all zeroes, or if it is not but split screen is active and the +part of the image being displayed is all zeroes, it is not contributing to +the output. However, the snap program cannot tell that an active image is +not contributing anything useful, +and so it dutifully reads out each pixel and adds zeroes to the output. +The moral of this is that frames of no interest should be (turned) off before +snap is called (unless you don't have anything better to do than wait for +computer prompts). When split screen is active, frames are read only for +the quadrants in which they are active. +.IP +The fastest snaps are for single images that are zoomed but not panned +and which are displayed (and snapped) in black and white, or snapped +in a single color. +.SH +\fBsplit\fR [c o px,y nx,y] +.IP +This command sets the split screen point. Option \fBc\fR is shorthand for +\fIcenter\fR, which is the normal selection. Option \fBo\fR stands for +\fIorigin\fR, and is the split position that corresponds to no split screen. +If you wish to specify the split point in pixels, use the \fBpx,y\fR form, in +which the coordinates are given as integers. If you prefer to specify +the point in NDC (which range from 0 though 1.0), use the \fBnx,y\fR form +in which the coordinates are decimal fractions. +.IP +A peculiarity of the IIS hardware is that if no split screen is desired, +the split point must be moved to the upper left corner of the display, rather +than to the lower left (the \fIIRAF\fR 1,1 position). This means that no +split screen (the \fBo\fR option, or what you get after \fBre r\fR) is really +split screen with only quadrant \fBfour\fR displayed: if you use the \fIdi\fR +command with quadrant specification, only quadrant 4 data will be seen. +.SH +\fBtell\fR +.IP +This command displays what little it knows about the display status. At +present, all it can say is whether any image plane is being displayed, and +if any are, what is the number of one of them. This rather weak performance +is the result of various design decisions both within \fIcv\fR and the +\fIIRAF\fR display code, and may be improved. +.SH +\fBwindow\fR (o) (F C) +.IP +This command operates just as the \fIpseudo\fR command, except that it +applies a linear mapping to the output look-up tables (if option \fBo\fR +is used) or to the frame specific tables. The mapping is controlled by +the trackball, with the \fIy\fR cursor coordinate supplying the slope +of the map, and \fIx\fR the offset. If different mappings are given to +each color, a form of pseudo-color is generated. +.SH +\fBwrite\fR [F C] text +.IP +This command writes the given text into either an image plane (or planes) +or into the specified color graphics bit plane(s). The user is prompted +to place the cursor at the (lower left) corner of the text, which is +then written to the right in roman font. The user is also asked for +a text size (default 1.0). If the text is written into a graphics +plane, and a \fBsnap\fR is requested with no color specification, then +text in any graphics plane will be included in the image. A color snap, +on the other hand, will include graphics text to the extent that the +text is displayed in that color. +Text written into an image plane +will have the same appearance as any "full on" pixel; that is, text +in an image plane is written at maximum intensity, +overwrites the image data, +and is affected by look-up tables, offsets, +and so forth, like any other image pixels. +.SH +\fBzoom\fR N (F) +.IP +This command zooms the display to the power given by \fBN\fR. For the +IIS, the power must be 1,2,4, or 8; anything else is changed to the next +lower legal value. The model 70 zooms all planes together. The center +of the zoom is determined by the cursor position relative to the first +frame specified (if none, the lowest numbered active one). Once the zoom +has taken place, the \fIpan\fR routine is called for the specified frames. diff --git a/pkg/images/tv/iis/doc/cv.hlp b/pkg/images/tv/iis/doc/cv.hlp new file mode 100644 index 00000000..6f90d74d --- /dev/null +++ b/pkg/images/tv/iis/doc/cv.hlp @@ -0,0 +1,341 @@ +.help cv Jan86 images.tv.iis +.ih +NAME +cv -- Control image device and take snapshots +.ih +USAGE +cv +.ih +PARAMETERS +.ls snap_file +Output file for snap image. +.le +.ls textsize +Character size for added text strings. +.le +.ih +COMMANDS +The following commands are available. This list is also available when +running the task with the commands h(elp) or ?. + +.nf +--- () : optional; [] : select one; N : number; C/F/Q : see below +b(link) N F (C Q) (F (C Q)..) blink (N = 10 is one second) +c(ursor) [on off F] cursor +di F (C Q) [on off] display image +dg C (F Q) [on off] display graphics +e(rase) [N a(ll) g(raphics) F] erase (clear) +m(atch) (o) F (C) (to) (F) (C) match (output) lookup table +o(ffset) C N offset color (N: 0 to +- 4095) +p(an) (F) pan images +ps(eudo) (o) (F C) (rn sn) pseudo color mapping + rn/sn: random n/seed n +r(ange) N (C) (N C ...) scale image (N: 1-8) +re(set) [r i t a] reset display + registers/image/tables/all +sn(ap) (C) snap a picture +s(plit) [c o px,y nx,y] split picture +t(ell) tell display state +w(indow) (o) (F C) window (output) frames +wr(ite) [F C] text write text to frame/graphics +z(oom) N (F) zoom frames (N: 1-8) +x or q exit/quit +--- C: letter c followed by r/g/b/a or, for snap r,g,b,m,bw,rgb, +--- or for dg r/g/b/y/p/m/w, as 'cr', 'ca', or 'cgb' +--- F: f followed by a frame number or 'a' for all +--- Q: q followed by quadrant number or t,b,l,r for top, bottom,... +.fi +.ih +DESCRIPTION +The \fIcv\fR program is used to control the image display from within +\fIIRAF\fR. It differs from most \fIIRAF\fR programs since it has its +own prompt and its own internal "language". Each of the available commands +is described in the following paragraphs, but first a few comments on the +command structure seem in order. Commands are distinguished by their +first letter, except for a few instances where the second letter is needed. +The rest of the command name can be typed if you wish. Commands often +require specification of frames numbers, colors, quadrants, or numeric +values. In most cases, the order is unimportant, but, zoom, for instance, +does require the zoom power right after the command name. The order given +in the \fIhelp\fR command will always work. + +A frame list is indicated in the \fIhelp\fR listing with an \fBF\fR. This +is to be replaced in the typed command by an \fBf\fR followed (no spaces) +with a list of the pertinent image planes. Thus, \fBf1\fR means +\fIframe 1\fR while \fBf42\fR means \fIframes 4\fR +and \fI2\fR. In most cases, the leading \fBf\fR can be omitted. +The specification \fBfa\fR means \fIall frames\fR. In those +cases in the \fIhelp\fR menu where the frame specification is optional, +omitting the frame list is the same as typing \fBfa\fR; that is, operate +on \fIall\fR frames. + +A color specification is a \fBc\fR followed by a set of letters. +The letter \fBa\fR means \fIall\fR, just as in the frame specification. +The letters \fBr, b,\fR and \fBg\fR are the other possibilities for all +commands other than \fIdg\fR and \fIsnap\fR. For displaying graphics +planes (\fBdg\fR), the other possibilities are \fBy, p, m, w\fR which +stand for \fIyellow, purple, mauve,\fR and \fIwhite\fR. (\fIMauve\fR is +the wrong name and will get changed.) The \fIsnap\fR command accepts, in +addition to the standard three colors, \fBm, bw,\fR and \fBrgb\fR, which +stand for \fImonochrome, black and white,\fR and \fIfull color\fR. (See +the discussion under \fIsnap\fR for further explanation.) +An omitted color specification is the same as \fIall colors\fR. + +Quadrants are given by a \fBq\fR followed by numbers from the set one through +four, or the letter \fBa\fR as in the frame and color cases. Quadrants are +numbered in the standard way, with the upper right being \fI1\fR, the upper +left \fI2\fR, etc. Adjacent quadrants may be referenced by \fBt, b, l,\fR +and \fBr\fR, standing for \fItop, bottom, left,\fR and \fIright\fR. An +omitted quadrant specification is the same as \fIall quadrants\fR. Quadrants +are effective only if the split screen command has set the split point to +something other than the "origin". + +.ls \fBblink\fR N F (C Q) (F C Q) +The blink rate is given by \fBN\fR, which is in tenths of a second. Although +current timing routines in \fIIRAF\fR do not recognize partial seconds, +for the NOAO 4.2BSD UNIX implementation, a non-portable timing routine is +used so that tenth seconds are usable. +Erratic timing is pretty much the rule when the system load is large. +One frame must be given, +followed by any color or quadrant specification, and then +optionally followed by any number of similar triads. A specification of +\fI10 f12 f3 f3 f4\fR would display frames one and two for one second, then +frame three for two one second intervals, then frame 4, and then recycle. +The first blink cycle may appear somewhat odd as the code "settles in", +but the sequence should become regular after that (except for timing +problems due to system load). In split screen mode, it is necessary to +specify all the frames together with quadrants, which leads to a lot of +typing: The reason is that blink simply cycles through a series of +\fBdi\fR commands, and hence it requires the same information as that +command. +.le +.ls \fBcursor\fR [on off F] +This command is used to turn the cursor on or off, and to read coordinates +and pixel values from a frame. Pixel coordinates for a feature are those +of the image as loaded into the display, and do not change as the image +is panned or zoomed. Fractional pixel positions are given for zoomed +images, with a minimum number of decimal places printed (but the same number +for both the \fIx\fR and \fIy\fR coordinates). +For an unpanned, unzoomed image plane, the lower left corner +of the \fIscreen\fR is (1,1) +even if the image you loaded is smaller than 512x512, occupies only +a portion of the display screen, and does not extend to the lower left +corner of the screen. This defect will likely be remedied +when the \fIcv\fR package is properly integrated into \fIIRAF\fR. +Pixel information can be read from a frame that is not being displayed. +.le +.ls \fBdi\fR F (C Q) [on off] +The \fId\fRisplay \fIi\fRmage command selects frames to be displayed on the +monitor. If neither \fIon\fR or \fIoff\fR is given, the specified frames +are turned on and all others are turned off. Turning a frame on with +the \fIon\fR specification displays the frames along with whatever else +is present; that is the new frame is added to the display. Note that +turning a frame off does not erase it. A frame need not have all colors +turned on, nor appear in all quadrants of a split screen display. +.le +.ls \fBdg\fR C (F Q) [on off] +The \fId\fRisplay \fIg\fRraphics command turns specific graphics planes +on or off. For the IIS display, neither the frame nor the quadrant +parameters are relevant. A side-effect of this command is that it +resets the graphics hardware to the \fIcv\fR standard: red cursor and +seven graphics planes, each colored differently. If the display is in +a "weird" state that is not cured with the \fIreset r/t\fR commands, +and a \fIreset i\fR would destroy images of interest, try a \fIdg ca on\fR +command followed by \fIdg ca off\fR. +.le +.ls \fBerase\fR [F all graphics] +This command erases the specified frame, or all the graphics planes, or +all data planes. The command \fBclear\fR is a synonym. +.le +.ls \fBmatch\fR (o) (F) (C) (to) (F) (C) +This command allows the user to copy a look-up table to a specified set +of tables, and hence, to match the mapping function of frames (and/or +colors) to a reference table. If the \fBo\fR parameter is omitted, the +match is among the look-up tables associated with particular frames; +otherwise, the \fIouput\fR tables are used (hence, the \fBo\fR). In the +latter case, only colors are important; the frame information should +be omitted. For the individual frame tables, colors can be omitted, in +which case a match of frame one to two means to copy the three tables +of frame two (red, green, and blue) to those of frame one. Only one +reference frame or color should be given, but \fImatch f23 cgb f1 cr\fR +is legal and means to match the green and blue color tables of both +frames two and three to the red table of frame one. +.le +.ls \fBoffset\fR C N +The value N, which can range from -4095 to +4095 is added to the data +pipeline for color \fBC\fR, thus offsetting the data. This is useful +if one needs to change the data range that is mapped into the useful part +of the output tables. +.le +.ls \fBpan\fR (F) +When invoked, this command connects the trackball to the specified frames +and allows the user to move (pan/roam/scroll) the image about the screen. +This function is automatically invoked whenever the zoom factor is changed. +.le +.ls \fBpseudo\fR (o) (F C) (rn sn) +Look-up tables are changed with the \fIwindow\fR and the \fIpseudocolor\fR +commands. Windowing provides linear functions and is discussed under that +command; \fIpseudo\fR provides pseudo-coloring capabilities. Pseudo-color +maps are usually best done in the output tables, rather than in the +look-up tables associated with particular frames; hence, \fBps o\fR is +the more likely invocation of the start of the command line. A color +(or colors) can be specified for "output" pseudocolor, in which case, only +those colors will be affected. For frame look-up tables, +the frame must be specified. + +Two mappings are provided. One uses a set of randomly selected colors +mapped to a specified number of pixel value ranges. The other uses +triangle color mappings. The former is invoked with the \fI(rn sn)\fR +options. In this case, the number following \fBr\fR gives the number of +ranges/levels into which the input data range is to be divided; to +each such range, a randomly selected color is assigned. The number +following \fBs\fR is a seed for the random number generator; changing +this while using the same number of levels gives different color mappings. +The default seed is the number of levels. If only the seed is given (\fBr\fR +omitted), the default number of levels is 8. This mapping is used when +a contour type display is desired: each color represents an intensity range +whose width is inversely proportional to the number of levels. + +The triangle mapping uses a different triangle in each of the three look-up +tables (either the sets associated with the specified frames, or the output +tables). The initial tables map low intensity to blue, middle values to +green, and high values to red, as shown in the diagram. (The red and blue +triangles are truncated as their centers are on a table boundary.) + +Once invoked, the program then allows the user to adjust the triangle +mapping. In +response to the prompt line, select the color to be changed and move the +trackball: the center of the triangle is given by the \fIx\fR cursor +coordinate and the width by the \fIy\fR coordinate. Narrow functions +(small \fIy\fR) allow one to map colors to a limited range of intensity. +When the mapping is satisfactory, a press of any button "fixes" the +mapping and the user may then either select another color or exit. +Before selecting a color, place the cursor at approximately the default +position for the mapping (or where it was for the last mapping of that +color under the current command); otherwise, the color map will change +suddenly when the color is selected via the trackball buttons. +.le +.ls \fBrange\fR N (C) (N C ...) +This command changes the range function in the specified color pipeline +so that the data is scaled by (divided by) the value \fBN\fR. For the +IIS, useful range values are 1,2,4 and 8; anything else will be changed +to the next lowest legal value. +.le +.ls \fBreset\fR [r i t a] +Various registers and tables are reset with this command. If the \fBr\fR +option is used, the registers are reset. This means that zoom is set to +one, all images are centered, split screen is removed, the range values are +set to one and the offset values are set to zero. Also, the cursor is +turned on and its shape is set. Option \fBi\fR causes all the image and +graphics planes to be erased and turned off. Option \fBt\fR resets all +the look-up tables to their default linear, positive slope, form, and +removes any color mappings by making all the output tables the same, and +all the frame specific tables the same. Option \fBa\fR does \fIall\fR +the above. +.le +.ls \fBsnap\fR (C) +This command creates an \fIIRAF\fR image file whose contents are a +512x512 digital snapshot of the image display screen. If no color +is specified, +or if \fIcm\fR (color monochromatic) is given, +the snapshot is of the \fIblue\fR image, which, if you +have a black and white image, is the same as the red or the green +image. Specifying \fBcg\fR for instance will take a snapshot of the +image that you would get had you specified \fIcg\fR for each frame +turned on by the \fIdi\fR command. Color is of interest only when +the window or pseudo color commands have made the three colors distinguishable. +If the "snapped" image is intended to be fed to the Dicomed film +recorder, a black and white image is all that is usually provided and so +a color snap is probably not appropriate. +In the case of the "no color/monochromatic" snap, the graphics planes are +all added together, while, if a real color is given, only the graphics +planes that have some of that color are included in the image. +The color \fBrgb\fR can be +given, in which case the red, green, and blue images are weighted equally +to produce a single image file. This image does not represent well what +you see, partly because of the equal weight given all colors: some +mapping of eye sensitivity is probably what is required, but it is not +implemented. + +The program operates by first determining zoom, pan, offset, tables, etc, +and, for each quadrant of the split screen, which images planes are active. +Then, for each line of the display, those images are read out from the display's +memory and the transformations done in hardware are duplicated pixel by pixel +in software. The word "active" needs a bit of explanation. Any image plane +whose pixels are contributing to the image is active. No image is active if +it has been turned off (by the \fIdi\fR) command (or if all images were +turned off and the one of interest not subsequently turned back on). If the +image is all zeroes, or if it is not but split screen is active and the +part of the image being displayed is all zeroes, it is not contributing to +the output. However, the snap program cannot tell that an active image is +not contributing anything useful, +and so it dutifully reads out each pixel and adds zeroes to the output. +The moral of this is that frames of no interest should be (turned) off before +snap is called (unless you don't have anything better to do than wait for +computer prompts). When split screen is active, frames are read only for +the quadrants in which they are active. + +The fastest snaps are for single images that are zoomed but not panned +and which are displayed (and snapped) in black and white, or snapped +in a single color. +.le +.ls \fBsplit\fR [c o px,y nx,y] +This command sets the split screen point. Option \fBc\fR is shorthand for +\fIcenter\fR, which is the normal selection. Option \fBo\fR stands for +\fIorigin\fR, and is the split position that corresponds to no split screen. +If you wish to specify the split point in pixels, use the \fBpx,y\fR form, in +which the coordinates are given as integers. If you prefer to specify +the point in NDC (which range from 0 though 1.0), use the \fBnx,y\fR form +in which the coordinates are decimal fractions. + +A peculiarity of the IIS hardware is that if no split screen is desired, +the split point must be moved to the upper left corner of the display, rather +than to the lower left (the \fIIRAF\fR 1,1 position). This means that no +split screen (the \fBo\fR option, or what you get after \fBre r\fR) is really +split screen with only quadrant \fBfour\fR displayed: if you use the \fIdi\fR +command with quadrant specification, only quadrant 4 data will be seen. +.le +.ls \fBtell\fR +This command displays what little it knows about the display status. At +present, all it can say is whether any image plane is being displayed, and +if any are, what is the number of one of them. This rather weak performance +is the result of various design decisions both within \fIcv\fR and the +\fIIRAF\fR display code, and may be improved. +.le +.ls \fBwindow\fR (o) (F C) +This command operates just as the \fIpseudo\fR command, except that it +applies a linear mapping to the output look-up tables (if option \fBo\fR +is used) or to the frame specific tables. The mapping is controlled by +the trackball, with the \fIy\fR cursor coordinate supplying the slope +of the map, and \fIx\fR the offset. If different mappings are given to +each color, a form of pseudo-color is generated. +.le +.ls \fBwrite\fR [F C] text +This command writes the given text into either an image plane (or planes) +or into the specified color graphics bit plane(s). The user is prompted +to place the cursor at the (lower left) corner of the text, which is +then written to the right in roman font. The user is also asked for +a text size (default 1.0). If the text is written into a graphics +plane, and a \fBsnap\fR is requested with no color specification, then +text in any graphics plane will be included in the image. A color snap, +on the other hand, will include graphics text to the extent that the +text is displayed in that color. +Text written into an image plane +will have the same appearance as any "full on" pixel; that is, text +in an image plane is written at maximum intensity, +overwrites the image data, +and is affected by look-up tables, offsets, +and so forth, like any other image pixels. +.le +.ls \fBzoom\fR N (F) +This command zooms the display to the power given by \fBN\fR. For the +IIS, the power must be 1,2,4, or 8; anything else is changed to the next +lower legal value. The model 70 zooms all planes together. The center +of the zoom is determined by the cursor position relative to the first +frame specified (if none, the lowest numbered active one). Once the zoom +has taken place, the \fIpan\fR routine is called for the specified frames. +.le +.ih +SEE ALSO +cvl +.endhelp diff --git a/pkg/images/tv/iis/doc/cv.ms b/pkg/images/tv/iis/doc/cv.ms new file mode 100644 index 00000000..d34ccaa0 --- /dev/null +++ b/pkg/images/tv/iis/doc/cv.ms @@ -0,0 +1,332 @@ +.TL +The "cv" Display Package +.AU +Richard Wolff +.DA +.PP +The \fIcv\fR program is used to control the image display from within +\fIIRAF\fR. It differs from most \fIIRAF\fR programs since it has its +own prompt and its own internal "language". Each of the available commands +is described in the following paragraphs, but first a few comments on the +command structure seem in order. Commands are distinguished by their +first letter, except for a few instances where the second letter is needed. +The rest of the command name can be typed if you wish. Commands often +require specification of frames numbers, colors, quadrants, or numeric +values. In most cases, the order is unimportant, but, zoom, for instance, +does require the zoom power right after the command name. The order given +in the \fIhelp\fR command will always work. +.PP +A frame list is indicated in the \fIhelp\fR listing with an \fBF\fR. This +is to be replaced in the typed command by an \fBf\fR followed (no spaces) +with a list of the pertinent image planes. Thus, \fBf1\fR means +.I "frame 1" +while \fBf42\fR means +.I "frames 4" +and \fI2\fR. In most cases, the leading \fBf\fR can be omitted. +The specification \fBfa\fR means \fIall frames\fR. In those +cases in the \fIhelp\fR menu where the frame specification is optional, +omitting the frame list is the same as typing \fBfa\fR; that is, operate +on \fIall\fR frames. +.PP +A color specification is a \fBc\fR followed by a set of letters. +The letter \fBa\fR means \fIall\fR, just as in the frame specification. +The letters \fBr, b,\fR and \fBg\fR are the other possibilities for all +commands other than \fIdg\fR and \fIsnap\fR. For displaying graphics +planes (\fBdg\fR), the other possibilities are \fBy, p, m, w\fR which +stand for \fIyellow, purple, mauve,\fR and \fIwhite\fR. (\fIMauve\fR is +the wrong name and will get changed.) The \fIsnap\fR command accepts, in +addition to the standard three colors, \fBm, bw,\fR and \fBrgb\fR, which +stand for \fImonochrome, black and white,\fR and \fIfull color\fR. (See +the discussion under \fIsnap\fR for further explanation.) +An omitted color specification is the same as \fIall colors\fR. +.PP +Quadrants are given by a \fBq\fR followed by numbers from the set one through +four, or the letter \fBa\fR as in the frame and color cases. Quadrants are +numbered in the standard way, with the upper right being \fI1\fR, the upper +left \fI2\fR, etc. Adjacent quadrants may be referenced by \fBt, b, l,\fR +and \fBr\fR, standing for \fItop, bottom, left,\fR and \fIright\fR. An +omitted quadrant specification is the same as \fIall quadrants\fR. Quadrants +are effective only if the split screen command has set the split point to +something other than the "origin". +.sp +.SH +\fBblink\fR N F (C Q) (F C Q) +.IP +The blink rate is given by \fBN\fR, which is in tenths of a second. Although +current timing routines in \fIIRAF\fR do not recognize partial seconds, +for the NOAO 4.2BSD UNIX implementation, a non-portable timing routine is +used so that tenth seconds are usable. +Erratic timing is pretty much the rule when the system load is large. +One frame must be given, +followed by any color or quadrant specification, and then +optionally followed by any number of similar triads. A specification of +\fI10 f12 f3 f3 f4\fR would display frames one and two for one second, then +frame three for two one second intervals, then frame 4, and then recycle. +The first blink cycle may appear somewhat odd as the code "settles in", +but the sequence should become regular after that (except for timing +problems due to system load). In split screen mode, it is necessary to +specify all the frames together with quadrants, which leads to a lot of +typing: The reason is that blink simply cycles through a series of +\fBdi\fR commands, and hence it requires the same information as that +command. +.SH +\fBcursor\fR [on off F] +.IP +This command is used to turn the cursor on or off, and to read coordinates +and pixel values from a frame. Pixel coordinates for a feature are those +of the image as loaded into the display, and do not change as the image +is panned or zoomed. Fractional pixel positions are given for zoomed +images, with a minimum number of decimal places printed (but the same number +for both the \fIx\fR and \fIy\fR coordinates). +For an unpanned, unzoomed image plane, the lower left corner +of the \fIscreen\fR is (1,1) +even if the image you loaded is smaller than 512x512, occupies only +a portion of the display screen, and does not extend to the lower left +corner of the screen. This defect will likely be remedied +when the \fIcv\fR package is properly integrated into \fIIRAF\fR. +Pixel information can be read from a frame that is not being displayed. +.SH +\fBdi\fR F (C Q) [on off] +.IP +The \fId\fRisplay \fIi\fRmage command turns specified frames on (or off). +Turning a frame off does not erase it. A frame need not have all colors +turned on, nor appear in all quadrants of a split screen display. +.SH +\fBdg\fR C (F Q) [on off] +.IP +The \fId\fRisplay \fIg\fRraphics command turns specific graphics planes +on or off. For the IIS display, neither the frame nor the quadrant +parameters are relevant. A side-effect of this command is that it +resets the graphics hardware to the \fIcv\fR standard: red cursor and +seven graphics planes, each colored differently. If the display is in +a "weird" state that is not cured with the \fIreset r/t\fR commands, +and a \fIreset i\fR would destroy images of interest, try a \fIdg ca on\fR +command followed by \fIdg ca off\fR. +.SH +\fBerase\fR [F all graphics] +.IP +This command erases the specified frame, or all the graphics planes, or +all data planes. The command \fBclear\fR is a synonym. +.SH +\fBmatch\fR (o) (F) (C) (to) (F) (C) +.IP +This command allows the user to copy a look-up table to a specified set +of tables, and hence, to match the mapping function of frames (and/or +colors) to a reference table. If the \fBo\fR parameter is omitted, the +match is among the look-up tables associated with particular frames; +otherwise, the \fIouput\fR tables are used (hence, the \fBo\fR). In the +latter case, only colors are important; the frame information should +be omitted. For the individual frame tables, colors can be omitted, in +which case a match of frame one to two means to copy the three tables +of frame two (red, green, and blue) to those of frame one. Only one +reference frame or color should be given, but \fImatch f23 cgb f1 cr\fR +is legal and means to match the green and blue color tables of both +frames two and three to the red table of frame one. +.SH +\fBoffset\fR C N +.IP +The value N, which can range from -4095 to +4095 is added to the data +pipeline for color \fBC\fR, thus offsetting the data. This is useful +if one needs to change the data range that is mapped into the useful part +of the output tables. +.SH +\fBpan\fR (F) +.IP +When invoked, this command connects the trackball to the specified frames +and allows the user to move (pan/roam/scroll) the image about the screen. +This function is automatically invoked whenever the zoom factor is changed. +.SH +\fBpseudo\fR (o) (F C) (rn sn) +.IP +Look-up tables are changed with the \fIwindow\fR and the \fIpseudocolor\fR +commands. Windowing provides linear functions and is discussed under that +command; \fIpseudo\fR provides pseudo-coloring capabilities. Pseudo-color +maps are usually best done in the output tables, rather than in the +look-up tables associated with particular frames; hence, \fBps o\fR is +the more likely invocation of the start of the command line. A color +(or colors) can be specified for "output" pseudocolor, in which case, only +those colors will be affected. For frame look-up tables, +the frame must be specified. +.IP +Two mappings are provided. One uses a set of randomly selected colors +mapped to a specified number of pixel value ranges. The other uses +triangle color mappings. The former is invoked with the \fI(rn sn)\fR +options. In this case, the number following \fBr\fR gives the number of +ranges/levels into which the input data range is to be divided; to +each such range, a randomly selected color is assigned. The number +following \fBs\fR is a seed for the random number generator; changing +this while using the same number of levels gives different color mappings. +The default seed is the number of levels. If only the seed is given (\fBr\fR +omitted), the default number of levels is 8. This mapping is used when +a contour type display is desired: each color represents an intensity range +whose width is inversely proportional to the number of levels. +.IP +The triangle mapping uses a different triangle in each of the three look-up +tables (either the sets associated with the specified frames, or the output +tables). The initial tables map low intensity to blue, middle values to +green, and high values to red, as shown in the diagram. (The red and blue +triangles are truncated as their centers are on a table boundary.) +.sp +.KS +.PS +B: box +move +G: box +move +R: box +move to B.sw left 0.375 +line dotted to B.nw +line dashed to B.s +move to G.sw +line dashed to G.n +line dashed to G.se +move to R.s +line dashed to R.ne +line dotted to R.se right 0.375 +"blue" at B.s below +"green" at G.s below +"red" at R.s below +.PE +.sp +.KE +.IP +Once invoked, the program then allows the user to adjust the triangle +mapping. In +response to the prompt line, select the color to be changed and move the +trackball: the center of the triangle is given by the \fIx\fR cursor +coordinate and the width by the \fIy\fR coordinate. Narrow functions +(small \fIy\fR) allow one to map colors to a limited range of intensity. +When the mapping is satisfactory, a press of any button "fixes" the +mapping and the user may then either select another color or exit. +Before selecting a color, place the cursor at approximately the default +position for the mapping (or where it was for the last mapping of that +color under the current command); otherwise, the color map will change +suddenly when the color is selected via the trackball buttons. +.SH +\fBrange\fR N (C) (N C ...) +.IP +This command changes the range function in the specified color pipeline +so that the data is scaled by (divided by) the value \fBN\fR. For the +IIS, useful range values are 1,2,4 and 8; anything else will be changed +to the next lowest legal value. +.SH +\fBreset\fR [r i t a] +.IP +Various registers and tables are reset with this command. If the \fBr\fR +option is used, the registers are reset. This means that zoom is set to +one, all images are centered, split screen is removed, the range values are +set to one and the offset values are set to zero. Also, the cursor is +turned on and its shape is set. Option \fBi\fR causes all the image and +graphics planes to be erased and turned off. Option \fBt\fR resets all +the look-up tables to their default linear, positive slope, form, and +removes any color mappings by making all the output tables the same, and +all the frame specific tables the same. Option \fBa\fR does \fIall\fR +the above. +.SH +\fBsnap\fR (C) +.IP +This command creates an \fIIRAF\fR image file whose contents are a +512x512 digital snapshot of the image display screen. If no color +is specified, +or if \fIcm\fR (color monochromatic) is given, +the snapshot is of the \fIblue\fR image, which, if you +have a black and white image, is the same as the red or the green +image. Specifying \fBcg\fR for instance will take a snapshot of the +image that you would get had you specified \fIcg\fR for each frame +turned on by the \fIdi\fR command. Color is of interest only when +the window or pseudo color commands have made the three colors distinguishable. +If the "snapped" image is intended to be fed to the Dicomed film +recorder, a black and white image is all that is usually provided and so +a color snap is probably not appropriate. +In the case of the "no color/monochromatic" snap, the graphics planes are +all added together, while, if a real color is given, only the graphics +planes that have some of that color are included in the image. +The color \fBrgb\fR can be +given, in which case the red, green, and blue images are weighted equally +to produce a single image file. This image does not represent well what +you see, partly because of the equal weight given all colors: some +mapping of eye sensitivity is probably what is required, but it is not +implemented. +.IP +The program operates by first determining zoom, pan, offset, tables, etc, +and, for each quadrant of the split screen, which images planes are active. +Then, for each line of the display, those images are read out from the display's +memory and the transformations done in hardware are duplicated pixel by pixel +in software. The word "active" needs a bit of explanation. Any image plane +whose pixels are contributing to the image is active. No image is active if +it has been turned off (by the \fIdi\fR) command (or if all images were +turned off and the one of interest not subsequently turned back on). If the +image is all zeroes, or if it is not but split screen is active and the +part of the image being displayed is all zeroes, it is not contributing to +the output. However, the snap program cannot tell that an active image is +not contributing anything useful, +and so it dutifully reads out each pixel and adds zeroes to the output. +The moral of this is that frames of no interest should be (turned) off before +snap is called (unless you don't have anything better to do than wait for +computer prompts). When split screen is active, frames are read only for +the quadrants in which they are active. +.IP +The fastest snaps are for single images that are zoomed but not panned +and which are displayed (and snapped) in black and white, or snapped +in a single color. +.SH +\fBsplit\fR [c o px,y nx,y] +.IP +This command sets the split screen point. Option \fBc\fR is shorthand for +\fIcenter\fR, which is the normal selection. Option \fBo\fR stands for +\fIorigin\fR, and is the split position that corresponds to no split screen. +If you wish to specify the split point in pixels, use the \fBpx,y\fR form, in +which the coordinates are given as integers. If you prefer to specify +the point in NDC (which range from 0 though 1.0), use the \fBnx,y\fR form +in which the coordinates are decimal fractions. +.IP +A peculiarity of the IIS hardware is that if no split screen is desired, +the split point must be moved to the upper left corner of the display, rather +than to the lower left (the \fIIRAF\fR 1,1 position). This means that no +split screen (the \fBo\fR option, or what you get after \fBre r\fR) is really +split screen with only quadrant \fBfour\fR displayed: if you use the \fIdi\fR +command with quadrant specification, only quadrant 4 data will be seen. +.SH +\fBtell\fR +.IP +This command displays what little it knows about the display status. At +present, all it can say is whether any image plane is being displayed, and +if any are, what is the number of one of them. This rather weak performance +is the result of various design decisions both within \fIcv\fR and the +\fIIRAF\fR display code, and may be improved. +.SH +\fBwindow\fR (o) (F C) +.IP +This command operates just as the \fIpseudo\fR command, except that it +applies a linear mapping to the output look-up tables (if option \fBo\fR +is used) or to the frame specific tables. The mapping is controlled by +the trackball, with the \fIy\fR cursor coordinate supplying the slope +of the map, and \fIx\fR the offset. If different mappings are given to +each color, a form of pseudo-color is generated. +.SH +\fBwrite\fR [F C] text +.IP +This command writes the given text into either an image plane (or planes) +or into the specified color graphics bit plane(s). The user is prompted +to place the cursor at the (lower left) corner of the text, which is +then written to the right in roman font. The user is also asked for +a text size (default 1.0). If the text is written into a graphics +plane, and a \fBsnap\fR is requested with no color specification, then +text in any graphics plane will be included in the image. A color snap, +on the other hand, will include graphics text to the extent that the +text is displayed in that color. +Text written into an image plane +will have the same appearance as any "full on" pixel; that is, text +in an image plane is written at maximum intensity, +overwrites the image data, +and is affected by look-up tables, offsets, +and so forth, like any other image pixels. +.SH +\fBzoom\fR N (F) +.IP +This command zooms the display to the power given by \fBN\fR. For the +IIS, the power must be 1,2,4, or 8; anything else is changed to the next +lower legal value. The model 70 zooms all planes together. The center +of the zoom is determined by the cursor position relative to the first +frame specified (if none, the lowest numbered active one). Once the zoom +has taken place, the \fIpan\fR routine is called for the specified frames. diff --git a/pkg/images/tv/iis/doc/cvl.hlp b/pkg/images/tv/iis/doc/cvl.hlp new file mode 100644 index 00000000..cda07b07 --- /dev/null +++ b/pkg/images/tv/iis/doc/cvl.hlp @@ -0,0 +1,287 @@ +.help cvl Jul87 images.tv.iis +.ih +NAME +cvl -- load images in image display +.ih +USAGE +cvl image frame +.ih +PARAMETERS +.ls image +Image to be loaded. +.le +.ls frame +Display frame to be loaded. +.le +.ls erase = yes +Erase frame before loading image? +.le +.ls border_erase = no +Erase unfilled area of window in display frame if the whole frame is not +erased? +.le +.ls select_frame = yes +Display the frame to be loaded? +.le +.ls fill = no +Interpolate or block average the image to fit the display window? +.le +.ls zscale = yes +Apply an automatic intensity mapping algorithm when loading the image? +.le +.ls contrast = 0.25 +Contrast factor for the automatic intensity mapping algorithm. +.le +.ls zrange = yes +If not using the automatic mapping algorithm (\fIzscale = no\fR) map the +full range of the image intensity to the full range of the display? +.le +.ls nsample_lines = 5 +Number of sample lines to use in the automatic intensity mapping algorithm. +.le +.ls xcenter = 0.5, ycenter = 0.5 +Horizontal and vertical centers of the display window in normalized +coordinates measured from the left and bottom respectively. +.le +.ls xsize = 1, ysize = 1 +Horizontal and vertical sizes of the display window in normalized coordinates. +.le +.ls xmag = 1., ymag = 1. +Horizontal and vertical image magnifications when not filling the display +window. Magnifications greater than 1 map image pixels into more than 1 +display pixel and magnifications less than 1 map more than 1 image pixel +into a display pixel. +.le +.ls z1, z2 +Minimum and maximum image intensity to be mapped to the minimum and maximum +display levels. These values apply when not using the automatic or range +intensity mapping methods. +.le +.ls ztrans = "linear" +Transformation of the image intensity levels to the display levels. The +choices are: +.ls "linear" +Map the minimum and maximum image intensities linearly to the minimum and +maximum display levels. +.le +.ls "log" +Map the minimum and maximum image intensities linearly to the range 1 to 1000, +take the logarithm (base 10), and then map the logarithms to the display +range. +.le +.ls "none" +Apply no mapping of the image intensities (regardless of the values of +\fIzscale, zrange, z1, and z2\fR). For most image displays, values exceeding +the maximum display value are truncated by masking the highest bits. +This corresponds to applying a modulus operation to the intensity values +and produces "wrap-around" in the display levels. +.le +.ls "user" +User supplies a look up table of intensities and their corresponding +greyscale values. +.le +.le +.ls lutfile = "" +Name of text file containing the look up table when \fIztrans\fR = user. +The table should contain two columns per line; column 1 contains the +intensity, column 2 the desired greyscale output. +.le +.ih +DESCRIPTION +The specified image is loaded into the specified frame of the standard +image display device ("stdimage"). For devices with more than one +frame it is possible to load an image in a frame different than that +displayed on the monitor. An option allows the loaded frame to become +the displayed frame. The previous contents of the frame may be erased +(which can be done very quickly on most display devices) before the +image is loaded. Without erasing, the image replaces only those pixels +in the frame defined by the display window and spatial mapping +described below. This allows displaying more than one image in a +frame. An alternate erase option erases only those pixels in the +defined display window which are not occupied by the image being +loaded. This is generally slower than erasing the entire frame and +should be used only if a display window is smaller than the entire +frame. + +The image is mapped both in intensity and in space. The intensity is +mapped from the image pixel values to the range of display values in +the device. Spatial interpolation maps the image pixel coordinates +into a part of the display frame called the display window. Many of +the parameters of this task are related to these two transformations. + +A display window is defined in terms of the full frame. The lower left +corner of the frame is (0, 0) and the upper right corner is (1, 1) as viewed on +the monitor. The display window is specified by a center (defaulted to the +center of the frame (0.5, 0.5)) and a size (defaulted to the full size of +the frame, 1 by 1). The image is loaded only within the display window and +does not affect data outside the window; though, of course, an initial +frame erase erases the entire frame. By using different windows one may +load several images in various parts of the display frame. + +If the option \fIfill\fR is selected the image is spatially interpolated +to fill the display window in its largest dimension (with an aspect +ratio of 1:1). When the display window is not automatically filled +the image is scaled by the magnification factors (which need not be +the same) and centered in the display window. If the number of image +pixels exceeds the number of display pixels in the window only the central +portion of the image which fills the window is loaded. By default +the display window is the full frame, the image is not interpolated +(no filling and magnification factors of 1), and is centered in the frame. +The spatial interpolation algorithm is described in the section +MAGNIFY AND FILL ALGORITHM. + +There are several options for mapping the pixel values to the display +values. There are two steps; mapping a range of image intensities to +the full display range and selecting the mapping function or +transformation. The mapping transformation is set by the parameter +\fIztrans\fR. The most direct mapping is "none" which loads the image +pixel values directly without any transformation or range mapping. +Most displays only use the lowest bits resulting in a wrap-around +effect for images with a range exceeding the display range. This is +sometimes desirable because it produces a contoured image which is not +saturated at the brightest or weakest points. This transformation is +also the fastest. Another transformation, "linear", maps the selected +image range linearly to the full display range. The logarithmic +transformation, "log", maps the image range linearly between 1 and 1000 +and then maps the logarithm (base 10) linearly to the full display +range. In the latter transformations pixel values greater than +selected maximum display intensity are set to the maximum display value +and pixel values less than the minimum intensity are set to the minimum +display value. + +Methods for setting of the range of image pixel values, \fIz1\fR and +\fIz2\fR, to be mapped to the full display range are arranged in a +hierarchy from an automatic mapping which gives generally good result +for typical astronomical images to those requiring the user to specify +the mapping in detail. The automatic mapping is selected with the +parameter \fIzscale\fR. The automatic mapping algorithm is described +in the section ZSCALE ALGORITHM and has two parameters, +\fInsample_lines\fR and \fIcontrast\fR. + +When \fIztrans\fR = user, a look up table of intensity values and their +corresponding greyscale levels is read from the file specified by the +\fIlutfile\fR parameter. From this information, a piecewise linear +look up table containing 4096 discrete values is composed. The text +format table contains two columns per line; column 1 contains the +intensity, column 2 the desired greyscale output. The greyscale values +specified by the user must match those available on the output device. +Task \fIshowcap\fR can be used to determine the range of acceptable +greyscale levels. When \fIztrans\fR = user, parameters \fIzscale\fR, +\fIzrange\fR and \fIzmap\fR are ignored. + +If the zscale algorithm is not selected the \fIzrange\fR parameter is +examined. If \fIzrange\fR is yes then \fIz1\fR and \fIz2\fR are set to +the minimum and maximum image pixels values, respectively. This insures +that the full range of the image is displayed but is generally slower +than the zscale algorithm (because all the image pixels must be examined) +and, for images with a large dynamic range, will generally show only the +brightest parts of the image. + +Finally, if the zrange algorithm is not selected the user specifies the +values of \fIz1\fR and \fIz2\fR directly. +.ih +ZSCALE ALGORITHM +The zscale algorithm is designed to display the image values near the median +image value without the time consuming process of computing a full image +histogram. This is particularly useful for astronomical images which +generally have a very peaked histogram corresponding to the background +sky in direct imaging or the continuum in a two dimensional spectrum. + +A subset of the image is examined. Approximately 600 pixels are +sampled evenly over the image. The number of lines is a user parameter, +\fInsample_lines\fR. The pixels are ranked in brightness to +form the function I(i) where i is the rank of the pixel and I is its value. +Generally the midpoint of this function (the median) is very near the peak +of the image histogram and there is a well defined slope about the midpoint +which is related to the width of the histogram. At the ends of the +I(i) function there are a few very bright and dark pixels due to objects +and defects in the field. To determine the slope a linear function is fit +with iterative rejection; + + I(i) = intercept + slope * (i - midpoint) + +If more than half of the points are rejected +then there is no well defined slope and the full range of the sample +defines \fIz1\fR and \fIz2\fR. Otherwise the endpoints of the linear +function are used (provided they are within the original range of the +sample): + +.nf + z1 = I(midpoint) + (slope / contrast) * (1 - midpoint) + z2 = I(midpoint) + (slope / contrast) * (npoints - midpoint) +.fi + +As can be seen, the parameter \fIcontrast\fR may be used to adjust the contrast +produced by this algorithm. +.ih +MAGNIFY AND FILL ALGORITHM +The spatial interpolation algorithm magnifies (or demagnifies) the +image along each axis by the desired amount. The fill option is a +special case of magnification in that the magnification factors are set +by the requirement that the image just fit the display window in its +maximum dimension with an aspect ratio (ratio of magnifications) of 1. +There are two requirements on the interpolation algorithm; all the +image pixels must contribute to the interpolated image and the +interpolation must be time efficient. The second requirement means that +simple linear interpolation is used. If more complex interpolation is +desired then tasks in the IMAGES package must be used to first +interpolate the image to the desired size before loading the display +frame. + +If the magnification factors are greater than 0.5 (sampling step size +less than 2) then the image is simply interpolated. However, if the +magnification factors are less than 0.5 (sampling step size greater +than 2) the image is first block averaged by the smallest amount such +that magnification in the reduced image is again greater than 0.5. +Then the reduced image is interpolated to achieve the desired +magnifications. The reason for block averaging rather than simply +interpolating with a step size greater than 2 is the requirement that +all of the image pixels contribute to the displayed image. If this is +not desired then the user can explicitly subsample using image +sections. The effective difference is that with subsampling the +pixel-to-pixel noise is unchanged and small features may be lost due to +the subsampling. With block averaging pixel-to-pixel noise is reduced +and small scale features still contribute to the displayed image. +.ih +EXAMPLES +For the purpose of these examples we assume a display with four frames, +512 x 512 in size, and a display range of 0 to 255. Also consider two +images, image1 is 100 x 200 with a range 200 to 2000 and image2 is +2000 x 1000 with a range -1000 to 1000. To load the images with the +default parameters: + +.nf + cl> cvl image1 1 + cl> cvl image2 2 +.fi + +The image frames are first erased and image1 is loaded in the center of +display frame 1 without spatial interpolation and with the automatic intensity +mapping. Only the central 512x512 area of image2 is loaded in display frame 2 + +To load the display without any intensity transformation: + + cl> cvl image1 1 ztrans=none + +The next example interpolates image2 to fill the full 512 horizontal range +of the frame and maps the full image range into the display range. Note +that the spatial interpolation first block averages by a factor of 2 and then +magnifies by 0.512. + + cl> cvl image2 3 fill+ zscale- + +The next example makes image1 square and sets the intensity range explicitly. + + cl> cvl image1 4 zscale- zrange- z1=800 z2=1200 xmag=2 + +The next example loads the two images in the same frame side-by-side. + +.nf + cl> cvl.xsize=0.5 + cl> cvl image1 fill+ xcen=0.25 + cl> cvl image2 erase- fill+ xcen=0.75 +.fi +.ih +SEE ALSO +display, magnify +.endhelp diff --git a/pkg/images/tv/iis/doc/erase.hlp b/pkg/images/tv/iis/doc/erase.hlp new file mode 100644 index 00000000..6a3548e6 --- /dev/null +++ b/pkg/images/tv/iis/doc/erase.hlp @@ -0,0 +1,26 @@ +.help erase Jan86 images.tv.iis +.ih +NAME +erase -- erase display frame +.ih +USAGE +erase frame +.ih +PARAMETERS +.ls frame +Frame to be erased. +.le +.ih +DESCRIPTION +The specified frame in the image display ("stdimage") is erased. +Note that the erased frame can be different than the frame currently +being displayed on the monitor. The graphics frame is not erased. +.ih +EXAMPLES +To erase frame 3: + + cl> erase 3 +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/frame.hlp b/pkg/images/tv/iis/doc/frame.hlp new file mode 100644 index 00000000..ec3a9059 --- /dev/null +++ b/pkg/images/tv/iis/doc/frame.hlp @@ -0,0 +1,24 @@ +.help frame Jan86 images.tv.iis +.ih +NAME +frame -- select frame to be displayed on the image display +.ih +USAGE +frame frame +.ih +PARAMETERS +.ls frame +Frame to be displayed. +.le +.ih +DESCRIPTION +The specified frame is displayed on the image display monitor ("stdimage"). +.ih +EXAMPLES +To display frame 3: + + cl> frame 3 +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/lumatch.hlp b/pkg/images/tv/iis/doc/lumatch.hlp new file mode 100644 index 00000000..95e6f800 --- /dev/null +++ b/pkg/images/tv/iis/doc/lumatch.hlp @@ -0,0 +1,28 @@ +.help lumatch Jan86 images.tv.iis +.ih +NAME +lumatch -- match lookup tables for two display frames +.ih +USAGE +lumatch frame ref_frame +.ih +PARAMETERS +.ls frame +Frame whose lookup table is to be adjusted. +.le +.ls ref_frame +Frame whose lookup table is to be matched. +.le +.ih +DESCRIPTION +The lookup tables mapping the display frame values to the grey levels +on the display monitor are matched in one frame to a reference frame. +.ih +EXAMPLES +To match the lookup tables in frame 3 to those in frame 1: + + cl> lumatch 3 1 +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/monochrome.hlp b/pkg/images/tv/iis/doc/monochrome.hlp new file mode 100644 index 00000000..70cc7aee --- /dev/null +++ b/pkg/images/tv/iis/doc/monochrome.hlp @@ -0,0 +1,18 @@ +.help monochrome Jan86 images.tv.iis +.ih +NAME +monochrome -- select monochrome enhancement +.ih +USAGE +monochrome +.ih +DESCRIPTION +Set the display monitor to display monochrome grey levels by setting +the lookup tables for each color gun to the same values. +.ih +EXAMPLES + cl> monochrome +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/pseudocolor.hlp b/pkg/images/tv/iis/doc/pseudocolor.hlp new file mode 100644 index 00000000..1c7bb70a --- /dev/null +++ b/pkg/images/tv/iis/doc/pseudocolor.hlp @@ -0,0 +1,41 @@ +.help pseudocolor Jan86 images.tv.iis +.ih +NAME +pseudocolor -- select pseudocolor enhancement +.ih +USAGE +pseudocolor +.ih +PARAMETERS +.ls enhancement +Type of pseudocolor enhancement. The types are: +.ls "random" +A randomly chosen color is assigned to each display level. +.le +.ls "linear" +The display levels are mapped into a spectrum. +.le +.ls "8color" +Eight colors are chosen at random over the range of the display levels. +.le +.le +.ls window = yes +Window the lookup table for the frame after enabling the pseudocolor? +.le +.ih +DESCRIPTION +The display levels from the lookup table are mapped into various saturated +colors to enhance an image. There is a choice of three color mappings. +After the pseudocolor enhancement is enabled on the display monitor the +user may, optionally, adjust the frame lookup table. +.ih +EXAMPLES +.nf + cl> pseudocolor random + cl> pseudocolor 8color + cl> pseudocolor linear +.fi +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/rgb.hlp b/pkg/images/tv/iis/doc/rgb.hlp new file mode 100644 index 00000000..1bd9aa13 --- /dev/null +++ b/pkg/images/tv/iis/doc/rgb.hlp @@ -0,0 +1,33 @@ +.help rgb Jan86 images.tv.iis +.ih +NAME +rgb - select true color mode (red, green, and blue frames) +.ih +USAGE +rgb red_frame green_frame blue_frame +.ih +PARAMETERS +.ls red_frame +Frame to use for the red component. +.le +.ls green_frame +Frame to use for the green component. +.le +.ls blue_frame +Frame to use for the blue component. +.le +.ls window = no +Window the rgb lookup tables? +.le +.ih +DESCRIPTION +Set the display monitor to display rgb colors by using three frames to +drive the red, green, and blue guns of the color display monitor. +Optionally, window the rgb lookup tables. +.ih +EXAMPLES + cl> rgb 1 2 3 +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/window.hlp b/pkg/images/tv/iis/doc/window.hlp new file mode 100644 index 00000000..f98130c3 --- /dev/null +++ b/pkg/images/tv/iis/doc/window.hlp @@ -0,0 +1,38 @@ +.help window Jan86 images.tv.iis +.ih +NAME +window -- adjust the contrast and dc offset of the current frame +.ih +USAGE +window +.ih +DESCRIPTION +The lookup table between the display frame values and the values sent +to the display monitor is adjusted interactively to enhance the display. +The mapping is linear with two adjustable parameters; the intercept +and the slope. The two values are set with the image display cursor +in the two dimensional plane of the display. The horizontal position +of the cursor sets the intercept or zero point of the transformation. +Moving the cursor to the left lowers the zero point while moving the cursor to +the right increases the zero point. The vertical position of the cursor +sets the slope of the transformation. The middle of the display is zero +slope (all frame values map into the same output value) while points above +the middle have negative slope and points below the middle have positive +slope. Positions near the middle have low contrast while positions near +the top and bottom have very high contrast. By changing the slope from +positive to negative the image may be displayed as positive or negative. + +The interactive loop is exited by pressing any button on the cursor control. +.ih +EXAMPLES +.nf + cl> window + Window the display and push any button to exit: +.fi +.ih +BUGS +It may be necessary to execute FRAME before windowing. +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/doc/zoom.hlp b/pkg/images/tv/iis/doc/zoom.hlp new file mode 100644 index 00000000..85a0b604 --- /dev/null +++ b/pkg/images/tv/iis/doc/zoom.hlp @@ -0,0 +1,31 @@ +.help zoom Jan86 images.tv.iis +.ih +NAME +zoom - zoom in on the image (change magnification) +.ih +USAGE +zoom +.ls zoom_factor +Zoom factor by the display is to be expanded. The factors are powers +of 2; 1 = no zoom, 2 = factor of 2, 3 = factor of 4, and 4 = factor of 8. +.le +.ls window = no +Window the enlarged image? +.le +.ih +DESCRIPTION +The display is zoomed by the specified factor. A zoom factor of 1 is no +magnification and higher factors correspond to factors of 2. The zoom +replicates pixels on the monitor and only a part of the display frame +centered on the display cursor is visible. The window option allows +the user to adjust interactively with the cursor the part of the zoomed +frame. +.ih +EXAMPLES +To magnify the displayed frame by a factor of 2: + + cl> zoom 2 +.ih +SEE ALSO +cv +.endhelp diff --git a/pkg/images/tv/iis/erase.cl b/pkg/images/tv/iis/erase.cl new file mode 100644 index 00000000..4da666bc --- /dev/null +++ b/pkg/images/tv/iis/erase.cl @@ -0,0 +1,10 @@ +#{ ERASE -- Erase a greyscale display frame. + +# frame,i,a,1,1,4,frame to be erased +# saveframe,i,h + +{ + saveframe = _dcontrol.frame + _dcontrol (frame=frame, erase=yes) + _dcontrol (frame = saveframe) +} diff --git a/pkg/images/tv/iis/erase.par b/pkg/images/tv/iis/erase.par new file mode 100644 index 00000000..0f84180f --- /dev/null +++ b/pkg/images/tv/iis/erase.par @@ -0,0 +1,2 @@ +frame,i,a,1,1,4,frame to be erased +saveframe,i,h diff --git a/pkg/images/tv/iis/frame.cl b/pkg/images/tv/iis/frame.cl new file mode 100644 index 00000000..1252f7da --- /dev/null +++ b/pkg/images/tv/iis/frame.cl @@ -0,0 +1,5 @@ +#{ FRAME -- Select the frame to be displayed. + +{ + _dcontrol (type="frame", frame=frame) +} diff --git a/pkg/images/tv/iis/giis.par b/pkg/images/tv/iis/giis.par new file mode 100644 index 00000000..5e000c89 --- /dev/null +++ b/pkg/images/tv/iis/giis.par @@ -0,0 +1,7 @@ +input,s,a,,,,input metacode file +device,s,h,"stdimage",,,output device +generic,b,h,no,,,ignore remaining kernel dependent parameters +debug,b,h,no,,,print decoded graphics instructions during processing +verbose,b,h,no,,,"print elements of polylines, cell arrays, etc. in debug mode" +gkiunits,b,h,no,,,print coordinates in GKI rather than NDC units +txquality,s,h,"normal","normal|low|medium|high",,character generator quality diff --git a/pkg/images/tv/iis/ids/doc/Imdis.hlp b/pkg/images/tv/iis/ids/doc/Imdis.hlp new file mode 100644 index 00000000..0ddd46e5 --- /dev/null +++ b/pkg/images/tv/iis/ids/doc/Imdis.hlp @@ -0,0 +1,793 @@ +.help imdis Dec84 "Image Display I/O" +.ce +\fBImage display I/O Design\fR +.ce +Richard Wolff +.ce +May 1985 +.sp 1 +.nh +Introduction + + The image display i/o interface uses the features of the GIO interface +to provide for the reading and writing of images and for the control of +the various subunits of a typical image display device. The cell array +calls of GIO are used for the image data, while the text and polyline +functions handle the text and line generation. Cursor reads are also +done with standard GIO calls. However, all the other display functions +are implemented through a series of GIO escape sequences, which are +described in this document. +.sp +.nh +Escape sequences + + Each sequence is described here, giving first a line with the count +of the number of words in the escape "instruction", followed by the data. +Since most of the data items might be more rationally considered arrays, +they are so indicated here. This means that in most cases, the number of +words in the escape instruction cannot be determined until run-time; an +indication of this is the use of "sizeof(arrays)" to indicate the number +of words in all the pseudo arrays. +.sp +Escape 10 -- reset +.ls +.tp 5 +1 hard/medium/soft +.ls +.nf +hard Clear image and graphics planes +medium reset all (lookup) tables to linear +soft reset scroll, zoom, cursor, alu, etc. +.fi +.le +.le +.sp +This sequence is used to preform various reset commands. These are not +done at GKOPENWS time because the user will not necessarily want to +upset the existing display when the image kernel is started up. +.sp +Escape 11 -- set image plane +.ls +.tp 4 +sizeof(arrays) IFA IBPL +.ls +.nf +IFA(i) image frame array +IBPL(i) image bit plane array +.fi +.le +.le +.sp +This sequence is essentially a header to the getcell/putcell calls. It +identifies both the frame(s) and bit plane(s) to be read or written. IFA +is an array of (short) integers, each of which specifies a plane (using +one indexing), the last element of the array being the integer IDS_EOD +to flag the End Of Data. IDS_EOD is a defined to be (-2). IBPL represents +the bit planes that are to be read or written for all the frames in IFA. +The data is IBPL is terminated with IDS_EOD. If the first element of IFA (or +IBPL) is IDS_EOD, all image frames (all bit planes) are involved in the I/O. +All "array" data are expected to be terminated with IDS_EOD, and the general +convention is maintained that IDS_EOD with no preceding data implies all +"frames", "colors", or whatever. +.sp +Escape 12 -- set graphics plane +.ls +.tp 4 +sizeof(arrays) GFA GBPL +.ls +.nf +GFA(i) graphics frame array +GBPL(i) graphics bit plane array +.fi +.le +.le +.sp +This sequence is identical to escape 11, but refers to graphics planes +instead of image planes. Generally, each graphics bit plane will refer to +a particular color, or perhaps, to a particular image plane. But there is +no enforced correspondence between graphics planes and image planes or colors. +The GFA specifies a set of graphics planes, and is probably unnecessary as the +bitplane array carries adequate information. Including it, however, retains +symmetry with escape 11. Thus, GFA cannot be omitted, for otherwise the +kernel would not know where GBPL started, but is set to IDS_EOD, and the +kernel can then find and ignore it. +.sp +Escape 13 -- display image +.ls +.tp 6 +1+sizeof(arrays) ON/OFF IFA ICOLOR IQUAD +.ls +.nf +ON/OFF turn frame on or off +IFA(i) image frame array +ICOLOR(i) image color array +IQUAD(i) image quadrant array (for split screen mode) +.fi +.le +.le +.sp +The specified image planes are all to be displayed in all the colors given +by ICOLOR. If ICOLOR(1) is IDS_EOD, a full color display is implied. +The quadrant value specifies which quadrant the frames are +to appear in--this is needed only when the split screen mode is in effect; +otherwise, IQUAD[1] = IDS_EOD. +.sp +Escape 14 -- display graphics +.ls +.tp 6 +1+sizeof(arrays) ON/OFF GBPL GCOLOR GQUAD +.ls +.nf +ON/OFF turn referenced planes on or off +GBPL(i) graphics bit plane array +GCOLOR(i) graphics color array +GQUAD(i) graphics quadrant array (for split screen mode) +.fi +.le +.le +.sp +This sequence is identical to escape 13, except for the substitution of +a bitplane array for frames, since graphics are usually treated bit by bit. +[With the IIS systems, for instance, this call requires manipulation of +the color-graphics lookup table.] +.sp +Escape 15 -- save device state +.ls +.tp 5 +1+sizeof(arrays) FD IFA GFA +.ls +.nf +FD file descriptor for save file +IFA(i) image frame array +GFA(i) graphics frame array +.fi +.le +.le +.sp +Saves the specified image frames and graphics planes and all the device +dependent status information in the file referenced by FD. Not implemented +in the Kernel (yet). +.sp +Escape 16 -- restore device state +.ls +.tp 5 +1+sizeof(arrays) FD IFA GFA +.ls +.nf +FD file descriptor for restore file +IFA(i) image frame array +GFA(i) graphics frame array +.fi +.le +.le +.sp +Restores the specified image frames and graphics planes and all the device +dependent status information from the file referenced by FD. Not implemented +in the Kernel (yet). +.sp +Escape 17 -- control +.ls +.tp 9 +4+sizeof(arrays) REG RW N FRAME COLOR OFFSET DATA +.ls +.nf +REG(i) control register or function +RW(i) read or write (write is 0, read 1, wait/read is 2) +N(i) Number of data values +FRAME(i) frame array +COLOR(i) color array +OFFSET(i) offset or other datum +DATA(Ni) array of data +.fi +.le +.le +.sp +Escape 18 is a very general sequence for writing any device +control register. Such "registers" include such generally available +capabilities as look-up tables, as well as specifics, such as min/max +registers. The upper level code may have to consult an "imagecap" +file to determine what it can request. + +FRAME, OFFSET, and COLOR, may not be needed for a particular operation, +but these arrays cannot be omitted; rather, use a one element array with +the value IDS_EOD. Should additional information be needed for an operation, +it can be transmitted in DATA. +.sp +.nh +Examples + +.sp +To clear all frames, one would issue the following sequence +.ls +.tp 4 +.nf +GKI_ESCAPE 11 IFA[1] = IDS_EOD IBPL[1] = IDS_EOD +GKI_CLEARWS +GKI_ESCAPE 12 IFA[1] = IDS_EOD IBPL[1] = IDS_EOD +GKI_CLEARWS +.fi +.le +.sp +To write an image to frame 2 ( IIS internal frame number 1 ) +.ls +.tp 2 +.nf +GKI_ESCAPE 11 IFA[1] = 2 IFA[2] = IDS_EOD IBPL[1] = IDS_EOD +GKI_PCELL data +.fi +.le +.sp +To activate frame 1 in red and green +.ls +.tp 2 +.nf +GKI_ESCAPE 13 IFA[1] = 1 IFA[2] = IDS_EOD ICOLOR[1] = IDS_RED + ICOLOR[2] = IDS_GREEN ICOLOR[3] = IDS_EOD + IQUAD[1] = IDS_EOD +.fi +.le +.sp +.bp +.nh +Defines + +This section presents the value and intended use of each of the various +defined constants. This list is likely to expand. + +.nf +define IDS_EOD (-2) # flag for end of data + +define IDS_RESET 10 # escape 10 +define IDS_R_HARD 0 # hard reset +define IDS_R_MEDIUM 1 # medium +define IDS_R_SOFT 2 +define IDS_R_SNAPDONE 3 # end snap + +define IDS_SET_IP 11 # escape 11 +define IDS_SET_GP 12 # escape 12 +define IDS_DISPLAY_I 13 # escape 13 +define IDS_DISPLAY_G 14 # escape 14 +define IDS_SAVE 15 # escape 15 +define IDS_RESTORE 16 # escape 16 + +# max sizes + +define IDS_MAXIMPL 16 # maximum number of image planes +define IDS_MAXGRPL 16 # maximum number of graphics planes +define IDS_MAXBITPL 16 # maximum bit planes per frame +define IDS_MAXGCOLOR 8 # maximum number of colors (graphics) +define IDS_MAXDATA 8192 # maximum data structure in display + +define IDS_RED 1 +define IDS_GREEN 2 +define IDS_BLUE 3 +define IDS_YELLOW 4 +define IDS_RDBL 5 +define IDS_GRBL 6 +define IDS_WHITE 7 +define IDS_BLACK 8 + +define IDS_QUAD_UR 1 # upper right quad.: split screen mode +define IDS_QUAD_UL 2 +define IDS_QUAD_LL 3 +define IDS_QUAD_LR 4 + +define IDS_CONTROL 17 # escape 17 +define IDS_CTRL_LEN 6 +define IDS_CTRL_REG 1 # what to control +define IDS_CTRL_RW 2 # read/write field in control instr. +define IDS_CTRL_N 3 # count of DATA items +define IDS_CTRL_FRAME 4 # pertinent frame(s) +define IDS_CTRL_COLOR 5 # and color +define IDS_CTRL_OFFSET 6 # generalized "register" +define IDS_CTRL_DATA 7 # data array + +define IDS_WRITE 0 # write command +define IDS_READ 1 # read command +define IDS_READ_WT 2 # wait for action, then read +define IDS_OFF 1 # turn whatever off +define IDS_ON 2 +define IDS_CBLINK 3 # cursor blink +define IDS_CSHAPE 4 # cursor shape + +define IDS_CSTEADY 1 # cursor blink - steady (no blink) +define IDS_CFAST 2 # cursor blink - fast +define IDS_CMEDIUM 3 # cursor blink - medium +define IDS_CSLOW 4 # cursor blink - slow + +define IDS_FRAME_LUT 1 # look-up table for image frame +define IDS_GR_MAP 2 # graphics color map...lookup table per + # se makes little sense for bit plane +define IDS_INPUT_LUT 3 # global input lut +define IDS_OUTPUT_LUT 4 # final lut +define IDS_SPLIT 5 # split screen coordinates +define IDS_SCROLL 6 # scroll coordinates +define IDS_ZOOM 7 # zoom magnification +define IDS_OUT_OFFSET 8 # output bias +define IDS_MIN 9 # data minimum +define IDS_MAX 10 # data maximum +define IDS_RANGE 11 # output range select +define IDS_HISTOGRAM 12 # output data histogram +define IDS_ALU_FCN 13 # arithmetic feedback function +define IDS_FEEDBACK 14 # feedback control +define IDS_SLAVE 15 # auxiliary host or slave processor + +define IDS_CURSOR 20 # cursor control - on/off/blink/shape +define IDS_TBALL 21 # trackball control - on/off +define IDS_DIGITIZER 22 # digitizer control - on/off + +define IDS_BLINK 23 # for blink request +define IDS_SNAP 24 # snap function +define IDS_MATCH 25 # match lookup tables + +# snap codes ... just reuse color codes from above. +define IDS_SNAP_RED IDS_RED # snap the blue image +define IDS_SNAP_GREEN IDS_GREEN # green +define IDS_SNAP_BLUE IDS_BLUE # blue +define IDS_SNAP_RGB IDS_BLACK # rgb image --- do all three +define IDS_SNAP_MONO IDS_WHITE # do just one + +# cursor parameters + +define IDS_CSET 128 # number of cursors per "group" + +define IDS_CSPECIAL 4097 # special "cursors" + # must be > (IDS_CSET * number of cursor groups) +define IDS_CRAW IDS_CSPECIAL # raw cursor read +define IDS_BUT_RD 4098 # "cursor number" for read buttons cmd +define IDS_BUT_WT 4099 # wait for button press, then read +define IDS_CRAW2 4100 # a second "raw" cursor +.fi +.nh +Explanation + + Most of the control functions of an image display do not fit within +the standard GIO protocols, which is why the escape function is provided. +However, image displays exhibit a wide range of functionality, and some +balance must be achieved between code portability/device independence and +use of (possibly peculiar) capabilities of a particular device. The control +functions (such as IDS_FRAME_LUT, IDS_CURSOR, IDS_SLAVE) "selected" here +are, for the most part, general functions, but the code was written with +the IIS Model 70 at hand (and in mind), and some "defines" reflect this. + + The model of the display is a device with some number of image frames, +each of which has associated with it an INPUT look-up table, used for +scaling or bit selection as data is written into the image frame; +a FRAME look-up table for each of the three primary colors, used to +alter the video stream from the image frame; combining logic that sums the +output of the various FRAME tables, forming three data streams, one for +each color; an OUTPUT look-up table that forms a final transformation +on each color prior to the data being converted to analog form; and +possibly, bias (OUT_OFFSET) and RANGE scaling applied somewhere in the +data stream (most likely near the OUTPUT look-up tables). + + Each image plane can be SCROLLed and ZOOMed independently (though +of course, not all devices can do this), and there may be SPLIT screen +capability, with the possibility of displaying parts of four images +simultaneously. + + Hooks have been provided in case there is a ALU or FEEDBACK hardware, +or there is a SLAVE processor, but use of these functions is likely to +be quite device dependent. The IIS can return to the user the MINimum +and MAXimum of a color data stream, and can also run a histogram on +selected areas of the display: There are "defines" pointing to these +functions, but their use is not yet specified and there is not yet +a clean way, within the GIO protocols, for reading back such data. + + Three functions that not so hardware oriented have "defines": +BLINK, MATCH and SNAP. The first is used if the hardware supports +blink. MATCH allows the kernel code to copy look-up tables---something +the upper level code could do were there a well defined mechanism for +reading non-image data back. SNAP is used to set-up the kernel so that +a subsequent set of get_cellarray calls can be used to return a data +stream that represents the digital data arriving at the +digital-to-analog converters: the kernel mimics the hardware and so +provides a digital snapshot of the image display screen. + + Images are loaded by a series of put_cellarray calls, preceded +by one IDS_SET_IP escape to configure the kernel to write the put_cell +data into the correct image planes (and optionally, specific bit planes). +The graphics planes are written to in the same manner, except that +IDS_SET_GP is used. It is not guaranteed that the SET_IP and SET_GP +are independent, and so the appropriate one should be given before +each put_cell sequence. Put_cells can be done for any arbitrary +rectangular array; they are turned into a series of writes to a +sequence of image rows by the GIO interface code. + + Calls to put_cell require the mapping of pixel coordinates +to NDC, which is made more complex than one might first +guess by the fact that the cell array operations are specified +by *inclusive* end points...See the write-up in "Note.pixel". + + Images planes are erased by the standard GIO gclear call, which +must be preceded by a SET_IP (or SET_GP for graphics). This is +perceived as reasonably consistent with the image loading as erasure +is loading with zeros, but presumably can be done far more efficiently +in most devices than with a series of put_cell calls. + + Images planes are turned on and off with IDS_DISPLAY_I, and graphics +planes with IDS_DISPLAY_G. Color and quadrant information must be +supplied as mentioned in the descriptions for escapes 13 and 14. + + The look-up tables are specified to the lower level code by giving +the end points of the line segments which describe the table function. +The end points are specified in NDC. This makes for a +simple, and device independent, upper level code. However, there is no +obvious (to the writer at least) code to invert the process, and return +end points for the simplest line segments that would describe a given +look-up table. (Moreover, there is no mechanism to return such information +to the upper level.) Therefore, the kernel code is asymmetric, in that +writes to the tables are fed data in the form of end points, but reads from +the tables (needed for the kernel implementation of SNAP) return the +requested number data values as obtained from the hardware. + + The control sequence for the ZOOM function requires, in addition to +the usual frame/color information, a zoom power followed by the GKI +coordinates of the pixel to be placed at the screen center. Likewise, +the SCROLL and SPLIT screen functions require GKI center coordinates. + + The OFFSET and RANGE sequences provide for bias and scaling of the +image data. Where they take effect is not specified. Offset requires +a signed number to be added to the referenced data; range is specified +by a small integer which selects the "range" of the data. + + Control of hardware cursors, trackballs, etc is provided: CURSOR +can be used to select cursor shape, blink rate, etc. Devices such as +(trackball) buttons are interrogated as if they are cursors, with a +cursor number that is greater than to IDS_CSPECIAL. The "key" value +returned by a "read" call to devices such as the trackball buttons will +be zero if no button was pressed or some positive number to represent +the activated device. Any "read" may be instructed to return +immediately (IDS_READ) or wait for some action (IDS_READ_WT); for +buttons, there are special IDS_BUT_RD/IDS_BUT_WT. + + Cursors are read and written through the standard GIO interface. +The cursor number ranges from 1 up through IDS_CSPECIAL-1. Each +frame has a set of set of cursors associated with it: frame n has +cursors numbered n, IDS_CSET+n, 2*IDS_CSET+n, etc. Currently, +IDS_CSPECIAL is 4097, and IDS_CSET is 128, so there can be 128 +different frames, each with 32 cursors. The coordinates associated +with a given cursor, and hence frame, are NDC for the pixel on which +the cursor is positioned. If a frame is not being displayed, a cursor +read for that frame will return NDC for the pixel that would appear at +the current cursor position if the frame were enabled. Note that the +NDC used in the cursor_set and cursor_read calls are relative to +the image planes in the display device; the fact the image data may +have come from a much larger user "world" is not, and can not be, +of any concern to the kernel code. + + Cursor 0 is special, and is not associated with a particular frame; +rather, the kernel is allowed to choose which frame to associate with +each cursor zero read or write. The IIS code picks the lowest numbered +frame that is on (being displayed). With split screen activated, a +frame can be "on" and not be seen; for cursor zero, what matters is +whether the frame video is active, not whether the split position +happens to be hiding the frame. The "key" value returned by the cursor +read routine is the frame number selected by the kernel. Cursor +IDS_CSPECIAL is also unusual, since it refers to the screen coordinates +and returns NDC for the screen. It is referred in the code as IDS_CRAW +(a "raw" cursor) and is needed for positioning the cursor at specific +points of the screen. + + The MATCH function requires that the frame and color information +of the control escape sequence point to the reference table; the +tables to be changed are given in the "data" part with the (IDS_EOD +terminated) frame sequence preceding the color information. The RW +field specifies which type of look-up table is to be changed. +.sp +.nh +Interface Routines + + The routines listed here are those used to implement the video +control package, and are found in the file "cvutil.x". +Arguments relating to image frames, image colors, display quadrants, +offset, range, and look-up table data are short integer arrays, +terminated by IDS_EOD. Cursor position (x and y) are NDC (hence, real). +All other arguments are integers. + +.ls cvclearg (frame, color) +Clears (erases) the given color (or colors) in the graphics frame given +by the argument "frame". For the IIS display, the "frame" argument +is not relevant, there being only one set of graphics frames. +.le +.ls cvcleari (frames) +Clears (erases) all bits in the given image display frames. +.le +.ls cv_rdbut +Reads the buttons on whatever device the kernel code associates with +this call, and returns an integer representing the button most recently +pressed. If none pressed, returns zero. +.le +.ls cv_wtbut +Same as cv_rdbut, but if no button pressed, waits until one is. This +routine will, therefore, always return a non-zero (positive) integer. +.le +.ls cv_rcur (cnum, x, y) +Reads the cursor "cnum" returning the NDC coordinates in x and y. The +mapping of cursor number to frame is described in the preceding +section: for cursors with numbers below IDS_CSET (128), the cursor +refers to the frame (cnum equal 5 means frame 5). +.le +.ls cv_scur (cnum, x, y) +Sets the cursor to the NDC given by x and y for the frame referenced by +cnum. +.le +.ls cv_scraw (x, y) +Sets the "raw cursor" to position (x,y). +.le +.ls cv_rcraw (x, y) +Reads the "raw cursor" position in (screen) NDC. +.le +.ls cvcur (cmd) +Turns the cursor on (cmd is IDS_ON) or off (IDS_OFF). +.le +.ls cvdisplay (instruction, device, frame, color, quad) +Turns on ("instruction" equals IDS_ON) image plane ("device" equals +IDS_DISPLAY_I) frame (or frames) in specified colors and quadrants. +Turn them off if "instruction" equals IDS_OFF. Manipulates graphics +planes instead if "device" equals IDS_DISPLAY_G. +.le +.ls cvmatch (type, refframe, refcolor, frames, color) +Copies the reference frame and reference color into the given frames +and color. For the IIS, "type" is either IDS_FRAME_LUT, referring to the +look-up tables associated with each frame, or IDS_OUTPUT_LUT, referring +to the global Output Function Memory tables. +.le +.ls cvoffset (color, data) +Sets the offset constants for the specified colors to values given in +"data"; if there are more colors given than corresponding data items, +the kernel will reuse the last data item as often as necessary. +.le +.ls cvpan (frames, x, y) +Moves the given frames so that the NDC position (x,y) is at the center +of the display. +.le +.ls cvrange (color, range) +Scales the output for the given colors; if there are more colors given +than corresponding range items, the kernel will reuse the last data item +as often as necessary. Range is a small number which specifies which +range the data is to be "put" in. For the IIS, there are only 4 useful +values (1,2,4, and 8); the kernel will map the requested value to the +next smallest legitimate one. +.le +.ls cvreset (code) +Resets the part of the display referenced by "code". For the IIS, a code +of IDS_R_HARD refers to (erasing) the image and graphics planes, IDS_R_MEDIUM +resets the various look-up tables, and IDS_R_SOFT resets the various registers +(such as zoom, scroll, range, split screen, and so forth). +.le +.ls cvsnap (filename, snap_color) +Creates an IRAF image file, named "filename", which represents the image +display video output for the specified color (IDS_SNAP_RED, IDS_SNAP_MONO, +etc). "filename" is a "char" array. The image is of the full display, +though, since the data is obtained from the kernel line by line via +get_cellarray calls, partial snapshots can be implemented easily. +.le +.ls cvsplit (x,y) +Sets the split screen point at NDC position (x,y). +.le +.ls cvtext (x, y, text, size) +Writes the given text at NDC position (x,y) in the specified size. +Currently, font and text direction are set to NORMAL. +.le +.ls cvwhich (frame) +Tells which frames are on. In the current implementation, this relies +on reading cursor 0: in this special case, the cursor variable passed +to ggcur() is changed by the kernel to reflect which frame it selected +(or ERR if no frame is active). +.le +.ls cvwlut (device, frames, color, data, n) +Writes the look-up tables associated with "frames" and "color". "device" +is IDS_FRAME_LUT or IDS_OUTPUT_LUT. The data to be written is given as +a series of line segments, and hence is described as a series of GKI +(x,y) pairs representing the line end points. For connected lines, +the first pair gives the first line segment starting coordinates, and all +following pairs the endpoints. The variable "n" gives the number of +values in "data"; there is no terminating IDS_EOD. +.le +.ls cvzoom (frames, power, x, y) +Zooms, to the given power, the specified frames with each frame +centered, after the zoom, at the given NDC position. +.le + + The following two support routines are included in the interface +package. +.ls cv_move (in, out) +Copies the short array "in" into the short array "out", up to and +including a trailing IDS_EOD. This procedure returns the number of +items copied. +.le +.ls cv_iset (frames) +Implements the image display escape sequence, with the bitplane +argument to that escape sequence set to "all". +.le +.ls cv_gset (colors) +Implements the graphics display escape sequence, with the image +argument to that escape sequence set to "all". +.le +.sp +.nh +Example + + The following code is used to pan (scroll) the image in response +to a changing cursor position. It is assumed that the "frame" array +consists of a list of frames to be panned together, terminated, as +is almost everything in this code, by IDS_EOD. +.nf + +# Pan subroutine + +procedure pansub (frames) + +short frames[ARB] # frames to pan + +int button +int cnum, cv_rdbut() +real x,y, xc, yc +real oldx, oldy + +begin + button = cv_rdbut() # clear buttons by reading them + call eprintf ("Press any button when done\n") + + # Where is cursor now? + # cv_rcraw uses the "RAW CURSOR" which reads and writes in + # screen (NDC) coordinates instead of image NDC. + + call cv_rcraw (xc,yc) + + # Pixel to NDC transformation is discussed in the file + # "Note.pixel" + + x = x_screen_center_in_NDC + y = y_screen_center_in_NDC + + call cv_scraw (x, y) # put cursor at screen center + + # Select a cursor---at least one per frame (conceptually at least) + + cnum = frames[1] + + # If cnum == IDS_EOD, the calling code did not select a frame. So, + # if cnum is 0, the kernel will select an active frame as the + # one to use when mapping NDC cursor positions to screen + # coordinates. + + if (cnum == IDS_EOD) + cnum = 0 + + # Determine NDC at screen center (where cursor was moved to) + # for frame of interest + call cv_rcur (cnum, x, y) + + # Restore cursor to original position + call cv_scraw (xc, yc) + + repeat { + oldx = xc + oldy = yc + repeat { + call cv_rcraw (xc, yc) + button = cv_rdbut() + } until ( (xc != oldx) || (yc != oldy) || (button > 0)) + # Determine change and reflect it about current screen + # center so image moves in direction cursor moves. + x = x - (xc - oldx) + y = y - (yc - oldy) + # If x or y are <0 or > 1.0, add or subtract 1.0 + "adjust x,y" + call cvpan (frames, x, y) + } until (button > 0) +end +.fi + [The call to cvpan may in fact need to be a series of calls, with +the array "frames" specifying one frame at a time, and (x,y) being the +new cursor position for that particular frame, so that differently panned +frames retain their relative offsets.] + The cursor and button routines are given here. +.nf + +# CV_RDBUT -- read button on trackball (or whatever) +# if none pressed, will get zero back + +int procedure cv_rdbut() + +int oldcnum +real x, y +int button +int gstati + +include "cv.com" + +begin + oldcnum = gstati (cv_gp, G_CURSOR) + call gseti (cv_gp, G_CURSOR, IDS_BUT_RD) + call ggcur (cv_gp, x, y, button) + call gseti (cv_gp, G_CURSOR, oldcnum) + return(button) +end + +# CV_RCUR -- read cursor. The cursor read/set routines do not restore +# the cursor number...this to avoid numerous stati/seti calls that +# usually are not needed. + +procedure cv_rcur (cnum, x, y) + +int cnum +real x,y +int junk + +include "cv.com" + +begin + call gseti (cv_gp, G_CURSOR, cnum) + call ggcur (cv_gp, x, y, junk) +end + +# CV_SCUR -- set cursor + +procedure cv_scur (cnum, x, y) + +int cnum +real x,y + +include "cv.com" + +begin + call gseti (cv_gp, G_CURSOR, cnum) + call gscur (cv_gp, x, y) +end + +# CV_SCRAW -- set raw cursor + +procedure cv_scraw (x, y) + +real x,y + +begin + call cv_scur (IDS_CRAW, x, y) +end +.fi + + The routine cv_move copies its first argument to the second up through +the required IDS_EOD termination, returning the number of items copied. +"cv_stack" is a pointer to a pre-allocated stack area that is used to +build the data array passed to the GIO escape function. + +.nf +# cvpan -- move the image(s) around + +procedure cvpan (frames, x, y) + +short frames[ARB] +real x,y # position in NDC +int count, cv_move() + +include "cv.com" + +begin + Mems[cv_stack] = IDS_SCROLL # Control Unit + Mems[cv_stack+1] = IDS_WRITE # Read/Write + + # Three is the number of data items (two coordinates) plus the + # terminating IDS_EOD. In many escape sequences, this number + # must be determined from the data rather than known in advance. + + Mems[cv_stack+2] = 3 + + # Move the frame data, which is of "unknown" length + + count = cv_move (frames, Mems[cv_stack+3]) + + # Color is unimportant here, but the color data must exist. The + # simplest solution is to use IDS_EOD by itself. + + Mems[cv_stack+3+count] = IDS_EOD # default to all colors + Mems[cv_stack+4+count] = 1 # (unused) offset + Mems[cv_stack+5+count] = x * GKI_MAXNDC + Mems[cv_stack+6+count] = y * GKI_MAXNDC + Mems[cv_stack+7+count] = IDS_EOD # for all frames + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], count+8) +end +.fi +.endhelp diff --git a/pkg/images/tv/iis/ids/doc/Note.misc b/pkg/images/tv/iis/ids/doc/Note.misc new file mode 100644 index 00000000..4b3a22de --- /dev/null +++ b/pkg/images/tv/iis/ids/doc/Note.misc @@ -0,0 +1,8 @@ +To implement a full device save/restore, we need: +zdev_restore(fd) +zdev_save(fd) +zim_save(fd,ipl) +zgr_save(fd,gpl) +zim_restore(fd,ipl) +zgr_restore(fd,gpl) +...zgr are just entry points into zim_{save,restore}(fd,pl) diff --git a/pkg/images/tv/iis/ids/doc/Note.pixel b/pkg/images/tv/iis/ids/doc/Note.pixel new file mode 100644 index 00000000..91c0338f --- /dev/null +++ b/pkg/images/tv/iis/ids/doc/Note.pixel @@ -0,0 +1,106 @@ + Herein is described how pixel coordinates should be encoded into +GKI metacode units and how this data is then converted back to pixel numbers +by the "lower level" code. For concreteness, the discussion is based on +a 512 x 512 display, where the pixels are numbered from 1 to 512 (one-based) +or 0 to 511 ( zero based). Only the X axis is discussed, the Y axis +being treated identically. + GKI metacode ranges from 0 through 32767, for a total of 32768 +values. In NDC coordinates, the range is from 0.0 through 1.0. +These coordinates are show in the diagram following. +.sp +.nf +last GKI coordinate of pixel + 63 127 191 255 319 32703 32767(!) +pixel | | | | | | | +extent-- |<-->||<-->||<-->||<-->||<-->|| ... |<-->||<--->| + | | | | | | | +the |-----|-----|-----|-----|-----| ... |-----|-----| +pixels | | | | | | ... | | | + |-----|-----|-----|-----|-----| ... |-----|-----| +num- (1-b) 1 2 3 4 5 511 512 +bers (0-b) 0 1 2 3 4 510 511 + | | | | | | ... | | | +GKI 0 64 128 192 256 320 32640 32704 32767(!) + | | | | | | ... | | | +NDC 0.0 1/512 2/512 3/512 4/512 5/512 511/512 1.0 +.fi +.sp + The pixels are not points, but rather, in GKI/NDC space, have +"physical" extent. In NDC coordinates, the pixel boundaries are +easily calculated as (left boundary = zero-based pixel number / 512) +and (right boundary = 1-based pixel number / 512). In GKI coordinates, +each pixel spans 64 GKI units, with the left boundary given by +"zero-based pixel number times 64". The right boundary is then the +left boundary plus 64 and then actually references the next pixel. +That is, the left boundary is included in the pixel, while the right +boundary is not. +(Pixel 0 goes from 0 through 63, pixel one from 64 through 127, etc.) +This works for all pixels except the last one, which would have a +right boundary of 32768; in this special case, the right boundary +is defined to be 32767. As will be seen later on, this should cause +no difficulties. + Explicit reference to a particular pixel should, in GKI +coordinates, refer to the pixel's left (or for Y, lower) edge. Thus, +pixel 7 (one-based system) is, in GKI, 6*64 or 384. + Cell arrays are denoted by their lower-left and upper-right +corners, with the understanding that all pixels WITHIN this rectangle +are to be read/written. Thus, an array that covers (one-based) +(4,10) to (18, 29) implies that, in X, pixels 4 through 17 are referenced. +Therefore, the GKI coordinate range is from 3*64 up to 17*64, where +3*64 is the GKI coordinate for the left edge of pixel 4 and 17*64 is +the GKI coordinate for the right edge of pixel 17. (Remember, the +right edge of pixel 512 is 32767, not 32768.) + The (real) NDC coordinate that is then passed to the interface code +is determined by dividing the GKI coordinate by 32767. The interface +code will, ultimately, multiply by 32767 to give the GKI coordinates +passed to the lower level. + The lower level code translates the GKI coordinate values into +zero-based pixel numbers by multiplying by 512/32768 ( not 32767). +The (real) pixel numbers so determined are then truncated, and become +the ones to scroll to, zoom to, or put the cursor on. Therefore, +when refering to single pixels for such operations, use the left +boundary of the pixel as the desired GKI/NDC coordinate. + Pixel computation for cell arrays is somewhat more complicated. +The right boundary of a cell array can be the left boundary for +an adjacent cell array; if the simple truncation scheme were used, that +coordinate would be included in both cell array operations, which is not +acceptable (especially for hard copy devices where the resultant overplotting +would be, at best, objectionable). This problem gives rise to the following +algorithm. Left (and lower) positions are rounded up to the next pixel +boundary if the fractional position is greater than or equal 0.5. Right +(and upper) positions are rounded down to the next pixel boundary if the +fractional position is less than 0.5; since a fractional pixel value of 0.0 +is less than 0.5, the right/upper pixel will be decreased even if it is +already on a boundary. The truncated values are then used as the +INCLUSIVE range of pixels to read or write. (If the positions lie +within the same pixel, that pixel becomes the X (or Y) range. If the +positions are in adjacent pixels, the right pixel operation is +not done if the left pixel moves into the same pixel as the right one.) + With this algorithm, the right edge of the display (NDC=1.0, +GKI=32767) becomes position 511.98, which is not rounded down as the +fractional part is >= 0.5, and, which, when truncated, turns into 511 +which is what is desired as the (last) included pixel in the range. + + For zoomed (image) displays, fractional pixel coordinates are +possible in the sense that, for a zoom of 4, pixels 16.0, 16.25, +16.50, and 16.75, all refer to the same datum. When setting the cursor, +the lower level code must distinguish all these cases, which have GKI +values (from a one-based coordinate system) 960, 976, 992, and 1008. +The lower level code will return these fractional pixel values when reading +the cursor, but the integral value is the real reference to the data +point. However, calls to the getcell and putcell routines should use +16 (aka 960) or the cell array rounding will interfere with what is +wanted. This does restrict getcell calls from starting/ending in the middle +of a zoomed (replicated) pixel, but makes the behavior of getcell +the same as putcell, which cannot write into the middle of a zoomed pixel. + + In summary, users should reference individual pixels by +specifying their left (or lower) boundaries in GKI/NDC. For cursor +reference on zoomed displays, fractional (in the sense outlined above) +pixels may be referenced. Right (or upper) boundaries are used only +for cell arrays, and except for the very right-most, are determined by +the user in an operation similar to that for the left boundaries. GKI +coordinates that are a little too large (not more than 31 units for a +512 resolution device) will be rounded/truncated to the desired +coordinate. For cell array operations only, ones a little too small +will still address the correct pixel. diff --git a/pkg/images/tv/iis/ids/doc/file.doc b/pkg/images/tv/iis/ids/doc/file.doc new file mode 100644 index 00000000..504a8330 --- /dev/null +++ b/pkg/images/tv/iis/ids/doc/file.doc @@ -0,0 +1,90 @@ +Some notes on the fio system. + Binary files. + open the binary file with + fio_fd = fopnbf(dev_name, mode, zopn_dev, zard_dev, zawr_dev, + zawt_dev, zstt_dev, zcl_dev) + where dev_name is a char string, terminated with EOS, + mode is READ_ONLY, READ_WRITE, WRITE_ONLY, NEW_FILE, APPEND, + TEMP_FILE, NEW_COPY + and the z routines are for open, read, write, wait, get status, + and close ( see system interface reference manual). + + The fio_fd that is returned is then used in calls to read, write, and flush. + They have the form write(fio_fd, buffer, #_of_chars) + read (fio_fd, buffer, #_of_chars) + flush(fio_fd) + seek (fio_fd, loffset) + long = note (fio_fd) + The output data will be buffered in a buffer of CHAR size as set by + a kernel call to zstt(). This can be overridden by + fsetl(fio_fd, F_BUFSIZE, buffer_size_in_char) + Partially filled buffers can be forced out by "flush". + Input data is buffered up before being made available to the + user; if an i/o call is needed to fill the buffer and it returns with + an inadequate number of data items, then the read returns with fewer + than requested itmes. + The file system can be made to use an external (local) buffer by + fseti(fio_fd, F_BUFPTR, new_buffer) + For general image i/o, it is desirable to set the ASYNC parameter to YES + fseti(fio_fd, F_ASYNC, YES) + If the device has a specific block size, this can be set by + fseti(fio_fd, F_BLKSIZE, value); + the file system will use this value for checking validity of block offsets + in reads and writes. If the value is zero, the device is considered a + "streaming" device, and no checks are done. + +(from Doug) +The device block size parameter is set at open time by all call to ZSTT__. +FIO is permissive and allows one to set almost anything with FSET, but some +of the parameters are best considered read only. This is documented at the +parameter level in . + +Image displays are NOT streaming devices, they are random access, block +structured devices. If you wish to defeat block alignment checking then +ZSTT__ may return a block size of 1 char. Note that not all image displays +are addressable at the pixel level. Even those that are are may be most +efficiently accessed using line at a time i/o (block size equals 1 line). + +If the block size is set to 1 FIO will still access the device in chunks +the size of the FIO buffer. The file area is partitioned up into a series +of "pages" the size of the FIO buffer and FIO will fault these pages in and +out when doing i/o. The only advantages of a block size of 1 are that the +FIO buffers may be any size (not much of an advantage), and more significantly, +AREAD and AWRITE calls may be used to randomly access the device. The latter +are asynchronous and are not buffered, and are the lowest level of i/o +provided by FIO. + + The form for the z routines is + zopn_dev(dev_name, mode, channel) + zard_dev(channel, buffer, length, offset) + zawr_dev(channel, buffer, length, offset) + zawt_dev(channel, bytes_read/written) + zstt_dev(channel, what, lvalue) + zcl_dev (channel, status) + + where channel is some number to be used however the z routines want, but + in the simplest case and under UNIX, would be the file descriptor of the + open file as determined by zopn_dev, or, in case of error, is ERR. + length and offset are in BYTES. zstt_dev() will be handled locally. + +Bytes, yes, but the file offsets are one-indexed. See the System Interface +reference manual. + + Each of the z*_dev routines above, with the exception of zstt_dev, will + ultimately result in a call to one of the system z routines for binary + files: zopnbf, zardbf, zawrbf, zawtbf, zclsbf. These routines take + the same arguments as the z*_dev routines, with the exception that + unix_fd is to be substituted for channel. "unix_fd" is the actual + file descriptor that results from the "real" open of the device by + zopnbf. It does not need to be visible above the z*_dev routines. + +The FIO z-routines for a device do not necessarily resolve into calls to the +ZFIOBF driver. It is desirable to structure things this way if we can since +it reduces the size of the kernel, but if necessary the z-routines can be +system dependent. Since the IIS is data driven and is interfaced in UNIX +as a file we were able to use the existing ZFIOBF driver, resulting in a +very clean interface. New devices should also be interfaced this way if +possible. For various reasons a data stream interface is almost always +preferable to a control interface (like Sebok's Peritek driver). I would +seriously consider adding a layer on a control driven device driver to make +it appear to be data driven, if the driver itself could not be modified. diff --git a/pkg/images/tv/iis/ids/doc/iis.doc b/pkg/images/tv/iis/ids/doc/iis.doc new file mode 100644 index 00000000..450de91a --- /dev/null +++ b/pkg/images/tv/iis/ids/doc/iis.doc @@ -0,0 +1,172 @@ +.TL +The IIS Image Display +.AU +Richard Wolff +.br +Central Computer Services +National Optical Astronomy Observatories +Tucson, Arizona +.DA +.PP +The International Imaging Systems (IIS) Model 70f is a reasonably +flexible image display with some more advanced capabilities than the IPPS, +(and, sad to say, some less advanced ones as well). This note describes +the hardware so that the user can use the device to best advantage. +The Model 75, which is in use at CTIO, is more elaborate still, but its +fundamental properties are the same as the 70f boxes in use at NOAO. +.PP +The image display has four image planes (frames, memories), each of which +can hold a 512 x 512 8 bit image. (The hardware can support 12 such planes, +but only four are installed in the NOAO units.) These planes are loaded +directly from the host computer; while there is hardware to support a +13-bit input/8-bit output mapping during load, this is not currently used +at NOAO. The frames are numbered 1 through 4 and there is nothing to +distinguish one from another. More than one image plane may be displayed +at one time; this may create a rather messy screen image, but, of course, +the hardware doesn't care. +.PP +The image is generated by hardware that +addresses each pixel in turn, and sends the data at that location to the +video display. Panning (scrolling/roaming) is accomplished simply by +starting the address generation somewhere other than at the normal starting +place. +Each plane has its own starting address, which just means that each +plane can be panned independently. In contrast, on the model 70, +all planes zoom together. Zooming is done by pixel replication: +The master address generator +"stutters", duplicating an address 2, 4, or 8 times before moving on to +the next pixel (and duplicating each line 2, 4, or 8 times--an additional +complication, but a necessary one, which is of interest only to hardware types). +The master address is then added to the per-image start address +and the resulting address streams are used to generate +the per-image data streams, which are added together to form the final image. +The net result of this is an image on the screen, with user control of the +placement of each image plane, and with one overall "magnification" factor. +.PP +If more than one image is active, the pixel values for a given screen +position are \fBadded\fR together. Thus, with four image planes, each of +which has pixels that can range in value from 0 through 255, the output +image can have pixel values that range from 0 through 3060. Unfortunately, +the output hardware can handle only values from 0 through 1023. But, +fortunately, hardware has been included to allow the use to offset and +scale the data back to the allowed output range. We will look at that +in more detail later. +.PP +The hardware that determines which frames are to be displayed consists +of "gates" that enable or disable the frame output to the image screen. +These "gates" are controlled by various data bits in the hardware. +Conceptually, given the description in the previous paragraphs, one can +imagine one bit (on or off) for each image frame, and it is these +bits that the \fBdi\fR command turns on and off. However, there are +complications, one of which is the split screen mode. Split screen +hardware allows the user to specify a point, anywhere on the screen, +where the screen will be divided into (generally, unequally sized) quadrants. +The display control bits specify not only which images will be active, +but in which of the four quadrants they will be active. +There are four control bits per image plane, and so, any image can +be displayed in any number of quadrants (including none, which means the +image is "off"). +.PP +If one imagines the split screen point in the middle of the screen, then +four quadrants are visible, number 1 being the upper right, number 4 the bottom +right, etc. As the split screen point is moved to the upper left, quadrant +four increases in size and the other three decrease. When the split point +reaches the top left corner (\fIIRAF\fR coordinate (1,512)), only quadrant +four is left. Due to a hardware decision, this is the normal, non-split, +screen configuration, the one you get when you type the \fBs o\fR command. +It would make more sense to set the non-split position so the screen was +filled with quadrant one, but the hardware won't allow it. So, be +warned, if you have a split screen display, +and then reset the split point to the "unsplit" point, +what you see will be only what you had displayed in quadrant 4. +.PP +The model 70f is a color display, not monochrome, and this adds more +complexity. What happens is that the data from each enabled image plane +is replicated and sent to three \fIcolor pipelines\fR, +one for the \fIred\fR gun of the monitor, one for the \fIgreen\fR, +and one for the \fIblue\fR. If the pipeline data streams are +the same, we get a black and white image. If they differ, the +final screen image is colored. Since there are really three data streams +leaving each image plane, it should not be surprising that there are +display control bits for each color, as well as each quadrant, of each +image. Thus (and finally) there are 12 control bits, three colors in each +of four quadrants, for each image plane. One can set up a display with +different images in different quadrants, and each colored differently! +Of course, the coloration is somewhat primative as the choices are limited +to red on or off, green on or off, both red and green on (yellow), blue on +or off, etc. More control comes with look-up tables. +.PP +The data from the combined image planes is added together in the pipelines. +There are offset and range registers for each pipeline which allow you to +bias and scale the data. Offset allows you to add or subtract a 13 bit +number (+-4095) and range scales the data by a factor of 1,2,4, or 8. +These are of interest mostly when more than one image is combined; in this +case, the resulting stream of data should be adjusted so that it +has its most interesting data in the range 0 through 1023. +.PP +Why 1023? The reason is that after offset and range have taken their +toll, the data is "passed through" a 10 bit in/10 bit out look-up table. +Look-up tables are digital functions in which each input datum is used +as an index into a table and the resultant value that is thus "looked-up" +replaces the datum in the data stream. The look-up tables here +are known as the \fIoutput\fR +tables (or, as IIS would have it, the "Output Function Memories"). +There is one for +each of the three pipelines, and each accepts an input value of 10 bits, +which limits the data stream to 0 through 1023, +If the image data in the three pipelines are the same, and the output +tables are too, then a black and white image results. If, however, the +pipelines are identical but the tables are different, a colored image +results. Since this image is not a true color image, +but simply results from manipulating the three identical color +pipelines in differing ways, the result is called a pseudo-color image. +.PP +The simplest look-up table is a linear function, whose input values run +from 0 through 1023 and whose output values do the same. The trouble +with such a linear output table is that the usual case is a single image +being displayed, in which case the pipeline data is never more than 255. +With the unit slope table, the maximum output would be 255, which is +one-quarter of full intensity. A better table in this case would be one of +slope 4, so 255 would map to 1023 (maximum output). This is what the +default is, and above 255 input, all values are mapped to 1023. If, +however, two images are being displayed, then data values may be larger +than 255 (at overlap points), and as these all map to 1023, only full white +results. The range/offset registers may be of use here, or a different +output table should be used. +.PP +The output of the "output" tables is combined with the graphics and cursor +data and sent to the display screen. The graphics planes are one bit +deep; there are seven of them, and together with the cursor, they form +an "image" 8 bits deep. In this sense, the graphics planes are just +like image data, and in particular, they pan and zoom just as the +image planes do. Of course, the cursor is different. The graphics +planes are sent through a look-up table of their own, which determines +what happens when one graphics plane crosses/overlaps others and/or the +cursor. The resultant data replaces the pipeline data. The graphics +data can be added to the pipeline data instead of replacing it, but this +feature is not available in \fIcv\fR at this time. The cursor is really +a writable 46x64 bit array; thus, its shape can be changed, a feature +that may be made available to users. Note that there is no quadrant/split +screen control for the graphics planes. +.PP +The final complication, at least as far as the current software is +concerned, is that each image plane has its own set of three look-up +tables, one for each color. Thus, there are 4x3 frame look-up tables +and three output tables. The image tables affect only the data from +the associated image plane. It is the output of these tables that +forms the input to the three color pipelines. Each table is an 8 bit in/9 +bit out table, with the output being treated as a signed number (255 to +-256). (Combining 12 9 bit numbers (a full model 70f) can produce a 13 bit +number, which is why the offset hardware accepts 13 bit numbers.) In +the \fIcv\fR software, only positive numbers are used as output from +the tables. Typically, the image tables are loaded with linear +functions of varying slope and intercept. +.PP +With the two sets of tables, image and output, it is possible to create +all sorts of interesting pseudo-color images. One possibility is to +place the appropriate three mappings in the output tables so as to create +the color (for instance, red can be used only for pixels with large +values, blue for low values, green for middling ones). Then the image +tables can be set to adjust the contrast/stretch of the each image +individually, producing, one assumes, useful and/or delightful +pseudo-color images. diff --git a/pkg/images/tv/iis/ids/font.com b/pkg/images/tv/iis/ids/font.com new file mode 100644 index 00000000..ec1b0ec9 --- /dev/null +++ b/pkg/images/tv/iis/ids/font.com @@ -0,0 +1,207 @@ +# CHRTAB -- Table of strokes for the printable ASCII characters. Each character +# is encoded as a series of strokes. Each stroke is expressed by a single +# integer containing the following bitfields: +# +# 2 1 +# 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 +# | | | | | | | +# | | | +---------+ +---------+ +# | | | | | +# | | | X Y +# | | | +# | | +-- pen up/down +# | +---- begin paint (not used at present) +# +------ end paint (not used at present) +# +#------------------------------------------------------------------------------ + +# Define the database. + +short chridx[96] # character index in chrtab +short chrtab[800] # stroke data to draw the characters + +# Index into CHRTAB of each printable character (starting with SP). + +data (chridx(i), i=01,05) / 1, 3, 12, 21, 30/ +data (chridx(i), i=06,10) / 45, 66, 79, 85, 92/ +data (chridx(i), i=11,15) / 99, 106, 111, 118, 121/ +data (chridx(i), i=16,20) / 128, 131, 141, 145, 154/ +data (chridx(i), i=21,25) / 168, 177, 187, 199, 203/ +data (chridx(i), i=26,30) / 221, 233, 246, 259, 263/ +data (chridx(i), i=31,35) / 268, 272, 287, 307, 314/ +data (chridx(i), i=36,40) / 327, 336, 344, 352, 359/ +data (chridx(i), i=41,45) / 371, 378, 385, 391, 398/ +data (chridx(i), i=46,50) / 402, 408, 413, 425, 433/ +data (chridx(i), i=51,55) / 445, 455, 468, 473, 480/ +data (chridx(i), i=56,60) / 484, 490, 495, 501, 506/ +data (chridx(i), i=61,65) / 511, 514, 519, 523, 526/ +data (chridx(i), i=66,70) / 529, 543, 554, 563, 574/ +data (chridx(i), i=71,75) / 585, 593, 607, 615, 625/ +data (chridx(i), i=76,80) / 638, 645, 650, 663, 671/ +data (chridx(i), i=81,85) / 681, 692, 703, 710, 723/ +data (chridx(i), i=86,90) / 731, 739, 743, 749, 754/ +data (chridx(i), i=91,95) / 759, 764, 776, 781, 793/ +data (chridx(i), i=96,96) / 801/ + +# Stroke data. + +data (chrtab(i), i=001,005) / 36, 1764, 675, 29328, 585/ +data (chrtab(i), i=006,010) / 21063, 21191, 21193, 21065, 29383/ +data (chrtab(i), i=011,015) / 1764, 355, 29023, 351, 29027/ +data (chrtab(i), i=016,020) / 931, 29599, 927, 29603, 1764/ +data (chrtab(i), i=021,025) / 603, 29066, 842, 29723, 1302/ +data (chrtab(i), i=026,030) / 28886, 143, 29839, 1764, 611/ +data (chrtab(i), i=031,035) / 29256, 78, 20810, 21322, 21581/ +data (chrtab(i), i=036,040) / 21586, 21334, 20822, 20569, 20573/ +data (chrtab(i), i=041,045) / 20833, 21345, 29789, 1764, 419/ +data (chrtab(i), i=046,050) / 20707, 20577, 20574, 20700, 20892/ +data (chrtab(i), i=051,055) / 21022, 21025, 20899, 1187, 28744/ +data (chrtab(i), i=056,060) / 717, 21194, 21320, 21512, 21642/ +data (chrtab(i), i=061,065) / 21645, 21519, 21327, 21197, 1764/ +data (chrtab(i), i=066,070) / 1160, 20700, 20704, 20835, 21027/ +data (chrtab(i), i=071,075) / 21152, 21149, 20561, 20556, 20744/ +data (chrtab(i), i=076,080) / 21192, 29841, 1764, 611, 21023/ +data (chrtab(i), i=081,085) / 21087, 21155, 21091, 1764, 739/ +data (chrtab(i), i=086,090) / 21087, 21018, 21009, 21068, 29384/ +data (chrtab(i), i=091,095) / 1764, 547, 21151, 21210, 21201/ +data (chrtab(i), i=096,100) / 21132, 29192, 1764, 93, 29774/ +data (chrtab(i), i=101,105) / 608, 29259, 78, 29789, 1764/ +data (chrtab(i), i=106,110) / 604, 29260, 84, 29780, 1764/ +data (chrtab(i), i=111,115) / 516, 21062, 21065, 21001, 21000/ +data (chrtab(i), i=116,120) / 21064, 1764, 84, 29780, 1764/ +data (chrtab(i), i=121,125) / 585, 21063, 21191, 21193, 21065/ +data (chrtab(i), i=126,130) / 21191, 1764, 72, 29859, 1764/ +data (chrtab(i), i=131,135) / 419, 20573, 20558, 20872, 21320/ +data (chrtab(i), i=136,140) / 21646, 21661, 21347, 20899, 1764/ +data (chrtab(i), i=141,145) / 221, 21155, 29320, 1764, 95/ +data (chrtab(i), i=146,150) / 20835, 21411, 21663, 21655, 20556/ +data (chrtab(i), i=151,155) / 20552, 29832, 1764, 95, 20899/ +data (chrtab(i), i=156,160) / 21347, 21663, 21658, 21334, 29270/ +data (chrtab(i), i=161,165) / 854, 5266, 21644, 21320, 20872/ +data (chrtab(i), i=166,170) / 28749, 1764, 904, 21411, 21283/ +data (chrtab(i), i=171,175) / 20561, 20559, 21391, 911, 13455/ +data (chrtab(i), i=176,180) / 1764, 136, 21320, 21645, 21652/ +data (chrtab(i), i=181,185) / 21337, 20889, 20565, 20579, 29859/ +data (chrtab(i), i=186,190) / 1764, 83, 20888, 21336, 21651/ +data (chrtab(i), i=191,195) / 21645, 21320, 20872, 20557, 20563/ +data (chrtab(i), i=196,200) / 20635, 29347, 1764, 99, 21667/ +data (chrtab(i), i=201,205) / 29064, 1764, 355, 20575, 20570/ +data (chrtab(i), i=206,210) / 20822, 20562, 20556, 20808, 21384/ +data (chrtab(i), i=211,215) / 21644, 21650, 21398, 20822, 918/ +data (chrtab(i), i=216,220) / 5274, 21663, 21411, 20835, 1764/ +data (chrtab(i), i=221,225) / 648, 21584, 21656, 21662, 21347/ +data (chrtab(i), i=226,230) / 20899, 20574, 20568, 20883, 21331/ +data (chrtab(i), i=231,235) / 21656, 1764, 602, 21210, 21207/ +data (chrtab(i), i=236,240) / 21079, 21082, 21207, 592, 21069/ +data (chrtab(i), i=241,245) / 21197, 21200, 21072, 21197, 1764/ +data (chrtab(i), i=246,250) / 602, 21146, 21143, 21079, 21082/ +data (chrtab(i), i=251,255) / 21143, 585, 21132, 21136, 21072/ +data (chrtab(i), i=256,260) / 21071, 21135, 1764, 988, 20628/ +data (chrtab(i), i=261,265) / 29644, 1764, 1112, 28824, 144/ +data (chrtab(i), i=266,270) / 29776, 1764, 156, 21460, 28812/ +data (chrtab(i), i=271,275) / 1764, 221, 20704, 20899, 21218/ +data (chrtab(i), i=276,280) / 21471, 21466, 21011, 21007, 521/ +data (chrtab(i), i=281,285) / 20999, 21127, 21129, 21001, 21127/ +data (chrtab(i), i=286,290) / 1764, 908, 20812, 20560, 20571/ +data (chrtab(i), i=291,295) / 20831, 21407, 21659, 21651, 21521/ +data (chrtab(i), i=296,300) / 21393, 21331, 21335, 21210, 21018/ +data (chrtab(i), i=301,305) / 20887, 20883, 21009, 21201, 21331/ +data (chrtab(i), i=306,310) / 1764, 72, 20963, 21219, 29768/ +data (chrtab(i), i=311,315) / 210, 5074, 1764, 99, 21411/ +data (chrtab(i), i=316,320) / 21663, 21658, 21398, 20566, 918/ +data (chrtab(i), i=321,325) / 5266, 21644, 21384, 20552, 20579/ +data (chrtab(i), i=326,330) / 1764, 1165, 21320, 20872, 20557/ +data (chrtab(i), i=331,335) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=336,340) / 99, 21347, 21662, 21645, 21320/ +data (chrtab(i), i=341,345) / 20552, 20579, 1764, 99, 20552/ +data (chrtab(i), i=346,350) / 29832, 86, 13078, 99, 29859/ +data (chrtab(i), i=351,355) / 1764, 99, 20552, 86, 13078/ +data (chrtab(i), i=356,360) / 99, 29859, 1764, 722, 21650/ +data (chrtab(i), i=361,365) / 29832, 1165, 4936, 20872, 20557/ +data (chrtab(i), i=366,370) / 20574, 20899, 21347, 29854, 1764/ +data (chrtab(i), i=371,375) / 99, 28744, 85, 5269, 1160/ +data (chrtab(i), i=376,380) / 29859, 1764, 291, 29603, 611/ +data (chrtab(i), i=381,385) / 4680, 328, 29576, 1764, 77/ +data (chrtab(i), i=386,390) / 20872, 21256, 21581, 29795, 1764/ +data (chrtab(i), i=391,395) / 99, 28744, 1160, 20887, 82/ +data (chrtab(i), i=396,400) / 13475, 1764, 99, 20552, 29832/ +data (chrtab(i), i=401,405) / 1764, 72, 20579, 21077, 21603/ +data (chrtab(i), i=406,410) / 29768, 1764, 72, 20579, 21640/ +data (chrtab(i), i=411,415) / 29859, 1764, 94, 20899, 21347/ +data (chrtab(i), i=416,420) / 21662, 21645, 21320, 20872, 20557/ +data (chrtab(i), i=421,425) / 20574, 862, 29859, 1764, 72/ +data (chrtab(i), i=426,430) / 20579, 21411, 21663, 21656, 21396/ +data (chrtab(i), i=431,435) / 20564, 1764, 94, 20557, 20872/ +data (chrtab(i), i=436,440) / 21320, 21645, 21662, 21347, 20899/ +data (chrtab(i), i=441,445) / 20574, 536, 29828, 1764, 72/ +data (chrtab(i), i=446,450) / 20579, 21411, 21663, 21657, 21398/ +data (chrtab(i), i=451,455) / 20566, 918, 13448, 1764, 76/ +data (chrtab(i), i=456,460) / 20808, 21384, 21644, 21649, 21397/ +data (chrtab(i), i=461,465) / 20822, 20570, 20575, 20835, 21411/ +data (chrtab(i), i=466,470) / 29855, 1764, 648, 21155, 99/ +data (chrtab(i), i=471,475) / 29923, 1764, 99, 20557, 20872/ +data (chrtab(i), i=476,480) / 21320, 21645, 29859, 1764, 99/ +data (chrtab(i), i=481,485) / 21064, 29795, 1764, 99, 20808/ +data (chrtab(i), i=486,490) / 21141, 21448, 29923, 1764, 99/ +data (chrtab(i), i=491,495) / 29832, 72, 29859, 1764, 99/ +data (chrtab(i), i=496,500) / 21079, 29256, 599, 13411, 1764/ +data (chrtab(i), i=501,505) / 99, 21667, 20552, 29832, 1764/ +data (chrtab(i), i=506,510) / 805, 20965, 20935, 29447, 1764/ +data (chrtab(i), i=511,515) / 99, 29832, 1764, 421, 21221/ +data (chrtab(i), i=516,520) / 21191, 29063, 1764, 288, 21091/ +data (chrtab(i), i=521,525) / 29600, 1764, 3, 29891, 1764/ +data (chrtab(i), i=526,530) / 547, 29341, 1764, 279, 21207/ +data (chrtab(i), i=531,535) / 21396, 21387, 21127, 20807, 20555/ +data (chrtab(i), i=536,540) / 20558, 20753, 21201, 21391, 907/ +data (chrtab(i), i=541,545) / 13447, 1764, 99, 28744, 76/ +data (chrtab(i), i=546,550) / 4424, 21256, 21516, 21523, 21271/ +data (chrtab(i), i=551,555) / 20823, 20563, 1764, 981, 21271/ +data (chrtab(i), i=556,560) / 20823, 20563, 20556, 20808, 21256/ +data (chrtab(i), i=561,565) / 29642, 1764, 1043, 4887, 20823/ +data (chrtab(i), i=566,570) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=571,575) / 1032, 29731, 1764, 80, 5136/ +data (chrtab(i), i=576,580) / 21523, 21271, 20823, 20563, 20556/ +data (chrtab(i), i=581,585) / 20808, 21256, 29707, 1764, 215/ +data (chrtab(i), i=586,590) / 29591, 456, 20958, 21153, 21409/ +data (chrtab(i), i=591,595) / 29727, 1764, 67, 20800, 21248/ +data (chrtab(i), i=596,600) / 21508, 29719, 1043, 21271, 20823/ +data (chrtab(i), i=601,605) / 20563, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=606,610) / 1764, 99, 28744, 83, 4439/ +data (chrtab(i), i=611,615) / 21271, 21523, 29704, 1764, 541/ +data (chrtab(i), i=616,620) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=621,625) / 533, 21077, 29256, 1764, 541/ +data (chrtab(i), i=626,630) / 21019, 21147, 21149, 21021, 21147/ +data (chrtab(i), i=631,635) / 533, 21077, 21058, 20928, 20736/ +data (chrtab(i), i=636,640) / 28802, 1764, 99, 28744, 84/ +data (chrtab(i), i=641,645) / 29530, 342, 13320, 1764, 483/ +data (chrtab(i), i=646,650) / 21089, 21066, 29384, 1764, 87/ +data (chrtab(i), i=651,655) / 28744, 584, 21076, 84, 4375/ +data (chrtab(i), i=656,660) / 20951, 21076, 21207, 21399, 21588/ +data (chrtab(i), i=661,665) / 29768, 1764, 87, 28744, 83/ +data (chrtab(i), i=666,670) / 20823, 21271, 21523, 29704, 1764/ +data (chrtab(i), i=671,675) / 83, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=676,680) / 21523, 21271, 20823, 20563, 1764/ +data (chrtab(i), i=681,685) / 87, 28736, 83, 20823, 21271/ +data (chrtab(i), i=686,690) / 21523, 21516, 21256, 20808, 20556/ +data (chrtab(i), i=691,695) / 1764, 1047, 29696, 1036, 21256/ +data (chrtab(i), i=696,700) / 20808, 20556, 20563, 20823, 21271/ +data (chrtab(i), i=701,705) / 21523, 1764, 87, 28744, 83/ +data (chrtab(i), i=706,710) / 20823, 21271, 29716, 1764, 74/ +data (chrtab(i), i=711,715) / 20808, 21256, 21514, 21518, 21264/ +data (chrtab(i), i=716,720) / 20816, 20562, 20565, 20823, 21271/ +data (chrtab(i), i=721,725) / 21461, 1764, 279, 29591, 970/ +data (chrtab(i), i=726,730) / 21320, 21128, 21002, 21025, 1764/ +data (chrtab(i), i=731,735) / 87, 20556, 20808, 21256, 21516/ +data (chrtab(i), i=736,740) / 1032, 29719, 1764, 151, 21064/ +data (chrtab(i), i=741,745) / 29719, 1764, 87, 20808, 21077/ +data (chrtab(i), i=746,750) / 21320, 29783, 1764, 151, 29704/ +data (chrtab(i), i=751,755) / 136, 29719, 1764, 87, 21064/ +data (chrtab(i), i=756,760) / 320, 29783, 1764, 151, 21527/ +data (chrtab(i), i=761,765) / 20616, 29704, 1764, 805, 21157/ +data (chrtab(i), i=766,770) / 21026, 21017, 20951, 20822, 20949/ +data (chrtab(i), i=771,775) / 21011, 21001, 21127, 21255, 1764/ +data (chrtab(i), i=776,780) / 611, 29273, 594, 29256, 1764/ +data (chrtab(i), i=781,785) / 485, 21093, 21218, 21209, 21271/ +data (chrtab(i), i=786,790) / 21398, 21269, 21203, 21193, 21063/ +data (chrtab(i), i=791,795) / 29127, 1764, 83, 20758, 20950/ +data (chrtab(i), i=796,800) / 21265, 21457, 29844, 1764, 0/ diff --git a/pkg/images/tv/iis/ids/font.h b/pkg/images/tv/iis/ids/font.h new file mode 100644 index 00000000..c33dc6ee --- /dev/null +++ b/pkg/images/tv/iis/ids/font.h @@ -0,0 +1,29 @@ +# NCAR font definitions. + +define CHARACTER_START 32 +define CHARACTER_END 126 +define CHARACTER_HEIGHT 26 +define CHARACTER_WIDTH 17 + +define FONT_LEFT 0 +define FONT_CENTER 9 +define FONT_RIGHT 27 +define FONT_TOP 36 +define FONT_CAP 34 +define FONT_HALF 23 +define FONT_BASE 9 +define FONT_BOTTOM 0 +define FONT_WIDTH 27 +define FONT_HEIGHT 36 + +define COORD_X_START 7 +define COORD_Y_START 1 +define COORD_PEN_START 13 +define COORD_X_LEN 6 +define COORD_Y_LEN 6 +define COORD_PEN_LEN 1 + +define PAINT_BEGIN_START 14 +define PAINT_END_START 15 +define PAINT_BEGIN_LEN 1 +define PAINT_END_LEN 1 diff --git a/pkg/images/tv/iis/ids/idscancel.x b/pkg/images/tv/iis/ids/idscancel.x new file mode 100644 index 00000000..b03aac61 --- /dev/null +++ b/pkg/images/tv/iis/ids/idscancel.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_CANCEL -- Cancel any buffered output. + +procedure ids_cancel (dummy) + +int dummy # not used at present +include "../lib/ids.com" + +begin + if (i_kt == NULL) + return + + # Just cancel any output in the FIO stream + call fseti (i_out, F_CANCEL, OK) +end diff --git a/pkg/images/tv/iis/ids/idschars.x b/pkg/images/tv/iis/ids/idschars.x new file mode 100644 index 00000000..4a53ad56 --- /dev/null +++ b/pkg/images/tv/iis/ids/idschars.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDSCHARS -- Write characters in the current plane + +procedure idschars (xs, ys, data, length, size, orien) + +int xs, ys # starting coordinates, GKI +char data[ARB] # the characters +int length # how many +int size # how big +int orien # character orientation + + +include "../lib/ids.com" + +begin + # Not implemented yet. +end diff --git a/pkg/images/tv/iis/ids/idsclear.x b/pkg/images/tv/iis/ids/idsclear.x new file mode 100644 index 00000000..6b6488d4 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsclear.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_CLEAR -- Clear an image frame. + +procedure ids_clear (dummy) + +int dummy # not used at present +include "../lib/ids.com" + +begin + if (i_kt == NULL) + return + call zclear(Mems[IDS_FRAME(i_kt)], Mems[IDS_BITPL(i_kt)], i_image) +end diff --git a/pkg/images/tv/iis/ids/idsclose.x b/pkg/images/tv/iis/ids/idsclose.x new file mode 100644 index 00000000..d77ade09 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsclose.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_CLOSE -- Close the image display kernel. +# Free up storage. + +procedure ids_close() + +include "../lib/ids.com" + +begin + call close(i_out) + call mfree (IDS_FRAME(i_kt), TY_SHORT) + call mfree (IDS_BITPL(i_kt), TY_SHORT) + call mfree (IDS_SBUF(i_kt), TY_CHAR) + call mfree (i_kt, TY_STRUCT) + i_kt = NULL +end diff --git a/pkg/images/tv/iis/ids/idsclosews.x b/pkg/images/tv/iis/ids/idsclosews.x new file mode 100644 index 00000000..40f7e40e --- /dev/null +++ b/pkg/images/tv/iis/ids/idsclosews.x @@ -0,0 +1,15 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_CLOSEWS -- Close the named workstation. + +procedure ids_closews (devname, n) + +short devname[n] # device name (not used) +int n # length of device name +include "../lib/ids.com" + +begin + call ids_flush(0) +end diff --git a/pkg/images/tv/iis/ids/idscround.x b/pkg/images/tv/iis/ids/idscround.x new file mode 100644 index 00000000..fc70a813 --- /dev/null +++ b/pkg/images/tv/iis/ids/idscround.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" +include + +# IDS_CROUND -- coordinate rounding. Since putcell and other similar +# calls are defined to include both the lower-left corner and the upper-right +# corners of the desired rectangle, it is necessary to "round" the +# coordinates so that adjacent rectangles do not have overlapping edges. +# This could have been done by agreeing that the top and right edges of the +# rectangle are not part of it, but this was not done in the GKI definition. +# Hence, here, we adopt the notion that if (for example) the upper y coordinate +# is in the top half of a pixel, that pixel is included and if the lower y +# coordinate is in the bottom half of a pixel, likewise, that pixel is included. +# Otherwise, the pixels are excluded from putcell. The x coordinates are +# treated similarly. +# The code depends on the fact that lower is <= upper, that upper will be +# at most GKI_MAXNDC, and that the device resolution will never be as much +# as (GKI_MAXNDC+1)/2. The last requirement stems from the fact that if +# the resolution were that high, each pixel would be 2 GKI units and +# the "rounding" based on whether or not we are in the upper or lower half +# of a pixel would probably fail due to rounding/truncation errors. + +procedure ids_cround(lower, upper, res) + +int lower, upper +real res # device resolution + +real low, up +real factor + +begin + factor = res/(GKI_MAXNDC+1) + low = real(lower) * factor + up = real(upper) * factor + + # if boundaries result in same row, return + if ( int(low) == int(up) ) + return + + # if low is in upper half of device pixel, round up + if ( (low - int(low)) >= 0.5 ) { + low = int(low) + 1 + # don't go to or beyond upper bound + if ( low < up ) { + # low already incremented; + # ... 0.2 just for "rounding protection" + lower = (low + 0.2)/factor + # if now reference same cell, return + if ( int(low) == int(up) ) + return + } + } + + # if "up" in bottom half of pixel, drop down one. Note that + # due to two "==" tests above, upper will not drop below lower. + # 0.2 means drop partway down into pixel below; calling code will + # truncate. + if ( (up - int(up)) < 0.5 ) + upper = (real(int(up)) - 0.2)/factor +end diff --git a/pkg/images/tv/iis/ids/idsdrawch.x b/pkg/images/tv/iis/ids/idsdrawch.x new file mode 100644 index 00000000..8372fac2 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsdrawch.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "font.h" + +define ITALIC_TILT 0.30 # fraction of xsize to tilt italics at top + + +# IDS_DRAWCHAR -- Draw a character of the given size and orientation at the +# given position. + +procedure ids_drawchar (ch, x, y, xsize, ysize, orien, font) + +char ch # character to be drawn +int x, y # lower left GKI coords of character +int xsize, ysize # width, height of char in GKI units +int orien # orientation of character (0 degrees normal) +int font # desired character font + +real px, py, sx, sy, coso, sino, theta +int stroke, tab1, tab2, i, pen +int bitupk() +include "font.com" + +begin + if (ch < CHARACTER_START || ch > CHARACTER_END) + i = '?' - CHARACTER_START + 1 + else + i = ch - CHARACTER_START + 1 + + # Set the font. + call ids_font (font) + + tab1 = chridx[i] + tab2 = chridx[i+1] - 1 + + theta = -DEGTORAD(orien) + coso = cos(theta) + sino = sin(theta) + + do i = tab1, tab2 { + stroke = chrtab[i] + px = bitupk (stroke, COORD_X_START, COORD_X_LEN) + py = bitupk (stroke, COORD_Y_START, COORD_Y_LEN) + pen = bitupk (stroke, COORD_PEN_START, COORD_PEN_LEN) + + # Scale size of character. + px = px / FONT_WIDTH * xsize + py = py / FONT_HEIGHT * ysize + + # The italic font is implemented applying a tilt. + if (font == GT_ITALIC) + px = px + ((py / ysize) * xsize * ITALIC_TILT) + + # Rotate and shift. + sx = x + px * coso + py * sino + sy = y - px * sino + py * coso + + # Draw the line segment or move pen. + if (pen == 0) + call ids_point (short(sx), short(sy), false) + else + call ids_vector (short(sx), short(sy)) + } +end diff --git a/pkg/images/tv/iis/ids/idsescape.x b/pkg/images/tv/iis/ids/idsescape.x new file mode 100644 index 00000000..3c0c404f --- /dev/null +++ b/pkg/images/tv/iis/ids/idsescape.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_ESCAPE -- Pass a device dependent instruction on to the kernel. +# Most of the display control work is done here. + +procedure ids_escape (fn, instruction, nwords) + +int fn # function code +short instruction[ARB] # instruction data words +int nwords # length of instruction + +pointer p,q +int ids_dcopy() +short frames[IDS_MAXIMPL+2] # storage for frame data +short color[IDS_MAXGCOLOR+1] # ditto for color +short bitpl[IDS_MAXBITPL+1] # ditto for graphics bit plane +short quad[5] # 4 quadrant information +int count, count2, total +int junk + +short gki[GKI_ESCAPE_LEN] +data gki[1] /BOI/, gki[2] /GKI_ESCAPE/ + +include "../lib/ids.com" + +begin + switch(fn) { + + case IDS_RESET: + call ids_reset(instruction[1]) + + case IDS_SET_IP: + p = IDS_FRAME(i_kt) + count = ids_dcopy(instruction[1], Mems[p]) + call ids_expand(Mems[p],i_maxframes, true) + q = IDS_BITPL(i_kt) + junk = ids_dcopy ( instruction[count+1], Mems[q]) + call ids_expand(Mems[q],IDS_MAXBITPL, false) + i_image = true + call zsetup (Mems[p], Mems[q], i_image) + + case IDS_SET_GP: + p = IDS_FRAME(i_kt) + count = ids_dcopy(instruction[1], Mems[p]) + call ids_expand(Mems[p],i_maxgraph, false) + q = IDS_BITPL(i_kt) + junk = ids_dcopy ( instruction[count+1], Mems[q]) + call ids_expand(Mems[q],IDS_MAXBITPL, false) + i_image = false + call zsetup (Mems[p], Mems[q], i_image) + + case IDS_DISPLAY_I: + count = ids_dcopy(instruction[2], frames[1]) + call ids_expand(frames[1], i_maxframes, true) + count2 = ids_dcopy (instruction[2+count], color[1]) + call ids_expand(color[1], IDS_MAXGCOLOR, false) + total = count + count2 + count = ids_dcopy(instruction[total+2], quad[1]) + call ids_expand(quad[1], 4, false) + call zdisplay_i(instruction[1], frames[1], color, quad) + + case IDS_DISPLAY_G: + count = ids_dcopy(instruction[2], bitpl[1]) + call ids_expand(bitpl[1], i_maxgraph, false) + count2 = ids_dcopy (instruction[2+count], color[1]) + call ids_expand(color[1], IDS_MAXGCOLOR, false) + total = count + count2 + count = ids_dcopy(instruction[total+2], quad[1]) + call ids_expand(quad[1], 4, false) + call zdisplay_g(instruction[1], bitpl, color, quad) + + case IDS_SAVE: + call idssave(instruction[1], nwords) + + case IDS_RESTORE: + call idsrestore(instruction[1], nwords) + + case IDS_CONTROL: + count = ids_dcopy(instruction[IDS_CTRL_FRAME], frames[1]) + call ids_expand(frames[1], i_maxframes, true) + count2 = ids_dcopy (instruction[IDS_CTRL_FRAME+count], color[1]) + call ids_expand(color[1], IDS_MAXGCOLOR, false) + total = count + count2 + call zcontrol(instruction[IDS_CTRL_REG], + instruction[IDS_CTRL_RW], + frames[1], color[1], + instruction[total+IDS_CTRL_FRAME], + instruction[IDS_CTRL_N], + instruction[total+IDS_CTRL_FRAME+1] ) + # if a read, would like to return the information in gki format + # but no mechanism (yet?) for that + } +end + +# IDS_DCOPY -- copy frame and bitplane information; return the number of +# items copied, including the IDS_EOD (whose presence is required and assumed). + +int procedure ids_dcopy(from, to) + +short from[ARB] # from this storage +short to[ARB] # to this area + +int i # count + +begin + i = 0 + repeat { + i = i + 1 + to[i] = from[i] + } until ( to[i] == IDS_EOD ) + return (i) +end diff --git a/pkg/images/tv/iis/ids/idsfa.x b/pkg/images/tv/iis/ids/idsfa.x new file mode 100644 index 00000000..b2d162c8 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsfa.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_FILLAREA -- Fill a closed area. + +procedure ids_fillarea (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs +include "../lib/ids.com" + +begin + # Not implemented yet. + call ids_polyline (p, npts) +end diff --git a/pkg/images/tv/iis/ids/idsfaset.x b/pkg/images/tv/iis/ids/idsfaset.x new file mode 100644 index 00000000..a8807766 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsfaset.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_FASET -- Set the fillarea attributes. + +procedure ids_faset (gki) + +short gki[ARB] # attribute structure +pointer fa +include "../lib/ids.com" + +begin + fa = IDS_FAAP(i_kt) + FA_STYLE(fa) = gki[GKI_FASET_FS] + FA_COLOR(fa) = gki[GKI_FASET_CI] +end diff --git a/pkg/images/tv/iis/ids/idsflush.x b/pkg/images/tv/iis/ids/idsflush.x new file mode 100644 index 00000000..cd177d40 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsflush.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_FLUSH -- Flush output. + +procedure ids_flush (dummy) + +int dummy # not used at present +include "../lib/ids.com" + +begin + if (i_kt == NULL) + return + + # We flush the FIO stream. + call flush (i_out) +end diff --git a/pkg/images/tv/iis/ids/idsfont.x b/pkg/images/tv/iis/ids/idsfont.x new file mode 100644 index 00000000..b3109f83 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsfont.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# IDS_FONT -- Set the character font. The roman font is normal. Bold is +# implemented by increasing the vector line width; care must be taken to +# set IDS_WIDTH so that the other vector drawing procedures remember to +# change the width back. The italic font is implemented in the character +# generator by a geometric transformation. + +procedure ids_font (font) + +int font # code for font to be set +int pk1, pk2, width +include "../lib/ids.com" + +begin + pk1 = GKI_PACKREAL(1.0) + pk2 = GKI_PACKREAL(2.0) + + width = IDS_WIDTH(i_kt) + + if (font == GT_BOLD) { + if (width != pk2) { + # Name collision with ids_open !! + # call ids_optn (*"inten", *"high") + width = pk2 + } + } else { + if (GKI_UNPACKREAL(width) > 1.5) { + # Name collision with ids_open !! + # call ids_optn (*"inten", *"low") + width = pk1 + } + } + + IDS_WIDTH(i_kt) = width +end diff --git a/pkg/images/tv/iis/ids/idsgcell.x b/pkg/images/tv/iis/ids/idsgcell.x new file mode 100644 index 00000000..6ba8245f --- /dev/null +++ b/pkg/images/tv/iis/ids/idsgcell.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# IDS_GETCELLARRAY -- Fetch a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure ids_getcellarray (nc, nr, ax1,ay1, ax2,ay2) + +int nc, nr # number of pixels in X and Y +int ax1, ay1 # lower left corner of input window +int ax2, ay2 # upper right corner of input window + +int x1, y1, x2, y2 +int nx,ny # number of device pixels in x and y +real px1, px2, py1, py2 + +real skip_x, skip_y, sx, sy +real blockx, blocky, bcy +int i, j, startrow, element +real xres, yres +pointer sp, cell +pointer mp # final data pointer to "array" m +bool ca, use_orig, new_row + +include "../lib/ids.com" + +begin + + # determine if can do real cell array. + + ca = (IDS_CELLARRAY(i_kt) != 0) + if ( !ca ) + return + + skip_x = 1.0 + skip_y = 1.0 + blockx = 1.0 + blocky = 1.0 + + xres = real(i_xres) + yres = real(i_yres) + + # adjust pixels for edges + x1 = ax1 + x2 = ax2 + y1 = ay1 + y2 = ay2 + call ids_cround(x1,x2,xres) + call ids_cround(y1,y2,yres) + + # find out how many real pixels we have to fetch + + px1 = real(x1) * xres /(GKI_MAXNDC+1) + py1 = real(y1) * yres /(GKI_MAXNDC+1) + px2 = real(x2) * xres /(GKI_MAXNDC+1) + py2 = real(y2) * yres /(GKI_MAXNDC+1) + + nx = int( px2 ) - int( px1 ) + 1 + ny = int( py2 ) - int( py1 ) + 1 + + # if too many data points in input, set skip. If skip is close + # enough to one, set it to one. + # set block replication factors - will be > 1.0 if too few input points. + # cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have + # enough points and so *some* have to be replicated. + + if ( nx > nc ) { + skip_x = real(nx)/nc + if ( (skip_x - 1.0)*(nc-1) < 1.0 ) + skip_x = 1.0 + } else + blockx = real(nc)/nx + + if ( ny > nr ) { + skip_y = real(ny)/nr + if ( (skip_y - 1.0)*(nr-1) < 1.0 ) + skip_y = 1.0 + } else + blocky = real(nr)/ny + + # initialize counters + + call smark(sp) + + # allocate storage for output + + call salloc (mp, nc*nr, TY_SHORT) + sy = 0 + bcy = blocky + startrow = 1 + + # see if we can use original data ... no massaging + # also set the initial value of the new_row flag, which tells + # if we have to rebuild the row data + # note that if blockx > 1.0, skip_x must be 1.0, and vv + + if ( (skip_x == 1.0) && (blockx == 1.0) ) { + use_orig = true + } else { + use_orig = false + # allocate storage for a row of pixels. + call salloc ( cell, nx, TY_SHORT) + } + new_row = true + + # do it + + for ( i = 1; i <= nr ; i = i + 1) { + + # fetch the row data. The reading routine will figure out + # how to read from the various individual frames and bitplanes. + + if ( new_row) { + if (!i_snap) + call zseek (i_out, int(px1), int(py1)+int(sy+0.5)) + if ( use_orig ) + # just copy it in + if (i_snap) + call do_snap (Mems[mp+startrow-1], nx, int(px1), + int(py1)+int(sy+0.5)) + else + call read (i_out, Mems[mp+startrow-1], nx) + else + # into Mems for rework + if (i_snap) + call do_snap (Mems[cell], nx, int(px1), + int(py1)+int(sy+0.5)) + else + call read (i_out, Mems[cell], nx) + } + + # rework the row data + + if ( !use_orig && new_row ) { + if ( skip_x == 1.0) + call ids_blockit(Mems[cell], Mems[mp+startrow-1], nc, + blockx) + else { + sx = 0 + for ( j = 1; j <= nc; j = j + 1) { + element = int(sx+0.5) + Mems[mp+startrow-1+j-1] = Mems[cell + element] + sx = sx + skip_x + } + } + } + # if don't need new row of input data, duplicate the + # previous one by copying within the "m" array + if ( ! new_row ) + call amovs (Mems[mp+startrow-1-nc], Mems[mp+startrow-1], nc) + + #advance a row + + startrow = startrow + nc + if ( bcy <= real(i) ) { + sy = sy + skip_y + bcy = bcy + blocky + new_row = true + } else { + new_row = false + } + } + + call gki_retcellarray (i_in, Mems[mp], nr * nc) + call sfree(sp) +end diff --git a/pkg/images/tv/iis/ids/idsgcur.x b/pkg/images/tv/iis/ids/idsgcur.x new file mode 100644 index 00000000..d3c0a1c6 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsgcur.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_GETCURSOR -- Get the position of a cursor. This is the low level +# cursor read procedure. Reading the image cursor is only possible when +# the ids kernel is run interactively, i.e., when the kernel is linked +# into the CL process, which owns the terminal. A raw binary read is required. +# The cursor value is returned as a GKI structure on the stream "i_in", +# i.e., it is sent back to the process which requested it. + +procedure ids_getcursor (cursor) + +int cursor + +int cur +int x, y, key + +include "../lib/ids.com" + +begin + cur = cursor + if ( cur > IDS_CSPECIAL ) { + switch( cur ) { + case IDS_BUT_RD, IDS_BUT_WT: + call iisbutton( cur, x, y, key) + } + } else + call zcursor_read (cur, x, y, key) + + call gki_retcursorvalue (i_in, x, y, key, cur) + call flush (i_in) +end diff --git a/pkg/images/tv/iis/ids/idsinit.x b/pkg/images/tv/iis/ids/idsinit.x new file mode 100644 index 00000000..7ac925a3 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsinit.x @@ -0,0 +1,172 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# IDS_INIT -- Initialize the ids data structures from the graphcap entry +# for the device. Called once, at OPENWS time, with the TTY pointer already +# set in the common. + +procedure ids_init (tty, devname) + +pointer tty # graphcap descriptor +char devname[ARB] # device name + +pointer nextch +int maxch, i +real char_height, char_width, char_size + +bool ttygetb() +real ttygetr() +int ttygeti(), btoi(), gstrcpy() + +include "../lib/ids.com" + +begin + # Allocate the ids descriptor and the string buffer. + if ( i_kt == NULL) { + call calloc (i_kt, LEN_IDS, TY_STRUCT) + call malloc (IDS_SBUF(i_kt), SZ_SBUF, TY_CHAR) + call malloc (IDS_BITPL(i_kt), IDS_MAXBITPL+1, TY_SHORT) + } else { + call mfree (IDS_FRAME(i_kt), TY_SHORT) + } + + + # Init string buffer parameters. The first char of the string buffer + # is reserved as a null string, used for graphcap control strings + # omitted from the graphcap entry for the device. + + IDS_SZSBUF(i_kt) = SZ_SBUF + IDS_NEXTCH(i_kt) = IDS_SBUF(i_kt) + 1 + Memc[IDS_SBUF(i_kt)] = EOS + + # get the device resolution from the graphcap entry. + + i_xres = ttygeti (tty, "xr") + if (i_xres <= 0) + i_xres = 512 + i_yres = ttygeti (tty, "yr") + if (i_yres <= 0) + i_yres = 512 + + + # Initialize the character scaling parameters, required for text + # generation. The heights are given in NDC units in the graphcap + # file, which we convert to GKI units. Estimated values are + # supplied if the parameters are missing in the graphcap entry. + + char_height = ttygetr (tty, "ch") + if (char_height < EPSILON) + char_height = 1.0 / 35.0 + char_height = char_height * GKI_MAXNDC + + char_width = ttygetr (tty, "cw") + if (char_width < EPSILON) + char_width = 1.0 / 80.0 + char_width = char_width * GKI_MAXNDC + + # If the device has a set of discreet character sizes, get the + # size of each by fetching the parameter "tN", where the N is + # a digit specifying the text size index. Compute the height and + # width of each size character from the "ch" and "cw" parameters + # and the relative scale of character size I. + + IDS_NCHARSIZES(i_kt) = min (MAX_CHARSIZES, ttygeti (tty, "th")) + nextch = IDS_NEXTCH(i_kt) + + if (IDS_NCHARSIZES(i_kt) <= 0) { + IDS_NCHARSIZES(i_kt) = 1 + IDS_CHARSIZE(i_kt,1) = 1.0 + IDS_CHARHEIGHT(i_kt,1) = char_height + IDS_CHARWIDTH(i_kt,1) = char_width + } else { + Memc[nextch+2] = EOS + for (i=1; i <= IDS_NCHARSIZES(i_kt); i=i+1) { + Memc[nextch] = 't' + Memc[nextch+1] = TO_DIGIT(i) + char_size = ttygetr (tty, Memc[nextch]) + IDS_CHARSIZE(i_kt,i) = char_size + IDS_CHARHEIGHT(i_kt,i) = char_height * char_size + IDS_CHARWIDTH(i_kt,i) = char_width * char_size + } + } + + # Initialize the output parameters. All boolean parameters are stored + # as integer flags. All string valued parameters are stored in the + # string buffer, saving a pointer to the string in the ids + # descriptor. If the capability does not exist the pointer is set to + # point to the null string at the beginning of the string buffer. + + IDS_POLYLINE(i_kt) = btoi (ttygetb (tty, "pl")) + IDS_POLYMARKER(i_kt) = btoi (ttygetb (tty, "pm")) + IDS_FILLAREA(i_kt) = btoi (ttygetb (tty, "fa")) + IDS_FILLSTYLE(i_kt) = ttygeti (tty, "fs") + IDS_ROAM(i_kt) = btoi (ttygetb (tty, "ro")) + IDS_CANZM(i_kt) = btoi (ttygetb (tty, "zo")) + IDS_ZRES(i_kt) = ttygeti (tty, "zr") + IDS_CELLARRAY(i_kt) = btoi (ttygetb (tty, "ca")) + IDS_SELERASE(i_kt) = btoi (ttygetb (tty, "se")) + + # how many image frames and graph (bit)planes do we get to play with? + + i_maxframes = ttygeti(tty, "ip") + if ( i_maxframes < 1 ) + i_maxframes = 1 + i_maxgraph = ttygeti(tty, "gp") + i_maxframes = min(int(i_maxframes), IDS_MAXIMPL) + i_maxgraph = min(int(i_maxgraph), IDS_MAXGRPL) + + # allocate space for the frame descriptors + # the "2" accounts for possible graphics channel ( see ids_expand.x) + # and the trailing IDS_EOD + + call malloc (IDS_FRAME(i_kt), max(i_maxframes,i_maxgraph)+2, TY_SHORT) + + # Initialize the input parameters: last cursor used. + + IDS_LCURSOR(i_kt) = 1 + + # Save the device string in the descriptor. + nextch = IDS_NEXTCH(i_kt) + IDS_DEVNAME(i_kt) = nextch + maxch = IDS_SBUF(i_kt) + SZ_SBUF - nextch + 1 + nextch = nextch + gstrcpy (devname, Memc[nextch], maxch) + 1 + IDS_NEXTCH(i_kt) = nextch + +end + + +# IDS_GSTRING -- Get a string value parameter from the graphcap table, +# placing the string at the end of the string buffer. If the device does +# not have the named capability return a pointer to the null string, +# otherwise return a pointer to the string. Since pointers are used, +# rather than indices, the string buffer is fixed in size. The additional +# degree of indirection required with an index was not considered worthwhile +# in this application since the graphcap entries are never very large. + +pointer procedure ids_gstring (cap) + +char cap[ARB] # device capability to be fetched +pointer strp, nextch +int maxch, nchars +int ttygets() + +include "../lib/ids.com" + +begin + nextch = IDS_NEXTCH(i_kt) + maxch = IDS_SBUF(i_kt) + SZ_SBUF - nextch + 1 + + nchars = ttygets (i_tty, cap, Memc[nextch], maxch) + if (nchars > 0) { + strp = nextch + nextch = nextch + nchars + 1 + } else + strp = IDS_SBUF(i_kt) + + IDS_NEXTCH(i_kt) = nextch + return (strp) +end diff --git a/pkg/images/tv/iis/ids/idsline.x b/pkg/images/tv/iis/ids/idsline.x new file mode 100644 index 00000000..ecc63d8c --- /dev/null +++ b/pkg/images/tv/iis/ids/idsline.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_LINE set the line type option in the nspp world + +procedure ids_line(index) + +int index # index for line type switch statement + +int linetype + +include "../lib/ids.com" + +begin + switch (index) { + case GL_CLEAR: + linetype = 0 + case GL_DASHED: + linetype = 0FF00X + case GL_DOTTED: + linetype = 08888X + case GL_DOTDASH: + linetype = 0F040X + default: + linetype = 0FFFFX # GL_SOLID and default + } + i_linemask = linetype +end diff --git a/pkg/images/tv/iis/ids/idslutfill.x b/pkg/images/tv/iis/ids/idslutfill.x new file mode 100644 index 00000000..be42c774 --- /dev/null +++ b/pkg/images/tv/iis/ids/idslutfill.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IDSLUTFILL -- Fill a lookup table from a set of line end points + +procedure idslfill (in, icount, out, lenlut, lutmin, lutmax) + +short in[ARB] # input: line end points +int icount # number of input data items +short out[ARB] # output: the lookup table +int lenlut # lut size +int lutmin,lutmax # inclusive range for lut values + +int i,j +int xs, ys, xe, ye +real slope + +begin + # xs and xe are zero based coordinates + xs = real(in[1]) * (lenlut - 1)/GKI_MAXNDC. + 0.5 + ys = real(in[2]) * (lutmax - lutmin)/GKI_MAXNDC. + lutmin + 0.5 + do i = 3, icount, 2 { + xe = real(in[i]) * (lenlut - 1)/GKI_MAXNDC. + 0.5 + ye = real(in[i+1]) * (lutmax - lutmin)/GKI_MAXNDC. + lutmin + 0.5 + if (xe != xs) { + slope = real(ye - ys) / (xe - xs) + do j = xs, xe { + out[j+1] = ys + (j - xs) * slope + } + } + xs = xe + ys = ye + } + out[1] = 0 # keep background at zero +end diff --git a/pkg/images/tv/iis/ids/idsopen.x b/pkg/images/tv/iis/ids/idsopen.x new file mode 100644 index 00000000..cee1aebe --- /dev/null +++ b/pkg/images/tv/iis/ids/idsopen.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_OPEN -- Install the image kernel as a kernel device driver. +# The device table DD consists of an array of the entry point addresses for +# the driver procedures. If a driver does not implement a particular +# instruction the table entry for that procedure may be set to zero, causing +# the interpreter to ignore the instruction. + +procedure ids_open (devname, dd) + +char devname[ARB] # nonnull for forced output to device +int dd[ARB] # device table to be initialized + +int locpr() +extern ids_openws(), ids_closews(), ids_clear(), ids_cancel() +extern ids_flush(), ids_polyline(), ids_polymarker(), ids_text() +extern ids_fillarea(), ids_putcellarray(), ids_plset() +extern ids_pmset(), ids_txset(), ids_faset() +extern ids_escape() +extern ids_setcursor(), ids_getcursor(), ids_getcellarray() + +include "../lib/ids.com" + +begin + # Flag first pass. Save forced device name in common for OPENWS. + + i_kt = NULL + call strcpy (devname, i_device, SZ_IDEVICE) + + # Install the device driver. + dd[GKI_OPENWS] = locpr (ids_openws) + dd[GKI_CLOSEWS] = locpr (ids_closews) + dd[GKI_DEACTIVATEWS] = 0 + dd[GKI_REACTIVATEWS] = 0 + dd[GKI_MFTITLE] = 0 + dd[GKI_CLEAR] = locpr (ids_clear) + dd[GKI_CANCEL] = locpr (ids_cancel) + dd[GKI_FLUSH] = locpr (ids_flush) + dd[GKI_POLYLINE] = locpr (ids_polyline) + dd[GKI_POLYMARKER] = locpr (ids_polymarker) + dd[GKI_TEXT] = locpr (ids_text) + dd[GKI_FILLAREA] = locpr (ids_fillarea) + dd[GKI_PUTCELLARRAY] = locpr (ids_putcellarray) + dd[GKI_SETCURSOR] = locpr (ids_setcursor) + dd[GKI_PLSET] = locpr (ids_plset) + dd[GKI_PMSET] = locpr (ids_pmset) + dd[GKI_TXSET] = locpr (ids_txset) + dd[GKI_FASET] = locpr (ids_faset) + dd[GKI_GETCURSOR] = locpr (ids_getcursor) + dd[GKI_GETCELLARRAY] = locpr (ids_getcellarray) + dd[GKI_ESCAPE] = locpr (ids_escape) + dd[GKI_SETWCS] = 0 + dd[GKI_GETWCS] = 0 + dd[GKI_UNKNOWN] = 0 +end diff --git a/pkg/images/tv/iis/ids/idsopenws.x b/pkg/images/tv/iis/ids/idsopenws.x new file mode 100644 index 00000000..bd25b260 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsopenws.x @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "../lib/ids.h" + +# IDS_OPENWS -- Open the named workstation. Once a workstation has been +# opened we leave it open until some other workstation is opened or the +# kernel is closed. Opening a workstation involves initialization of the +# kernel data structures. Initialization of the device itself is left to +# an explicit reset command. + +procedure ids_openws (devname, n, mode) + +short devname[ARB] # device name +int n # length of device name +int mode # access mode + +long filesize +bool need_open, same_dev +pointer sp, buf, devinfo + +long fstatl() +pointer ttygdes() +bool streq(), ttygetb() +int fopnbf(), ttygets() +extern zopnim(), zardim(), zawrim(), zawtim(), zsttim(), zclsim() +errchk ttygdes +int oldmode +data oldmode /-1/ + +include "../lib/ids.com" + +begin + call smark (sp) + call salloc (buf, max (SZ_FNAME, n), TY_CHAR) + call salloc (devinfo, SZ_LINE, TY_CHAR) + + # If a device was named when the kernel was opened then output will + # always be to that device (i_device) regardless of the device named + # in the OPENWS instruction. If no device was named (null string) + # then unpack the device name, passed as a short integer array. + + if (i_device[1] == EOS) { + call achtsc (devname, Memc[buf], n) + Memc[buf+n] = EOS + } else + call strcpy (i_device, Memc[buf], SZ_FNAME) + + # find out if first time, and if not, if same device as before + # note that if (i_kt == NULL), then same_dev is false. + + same_dev = false + need_open = true + if ( i_kt != NULL ) { + same_dev = (streq(Memc[IDS_DEVNAME(i_kt)], Memc[buf])) + if ( !same_dev || ( oldmode != mode)) + call close(i_out) + else + need_open = false + } + oldmode = mode + + # Initialize the kernel data structures. Open graphcap descriptor + # for the named device, allocate and initialize descriptor and common. + # graphcap entry for device must exist. + + if (need_open) { + if ((i_kt != NULL) && !same_dev) + call ttycdes (i_tty) + if (!same_dev) { + i_tty = ttygdes (Memc[buf]) + if (ttygetb (i_tty, "LC")) + call error (1, "operation not supported on device") + } + + if (ttygets (i_tty, "DD", Memc[devinfo], SZ_LINE) <= 0) + call strcpy (Memc[buf], Memc[devinfo], SZ_LINE) + + # Open the output file. The device is connected to FIO as a + # binary file. mode must be READ_WRITE or WRITE_ONLY + # for image display! + + iferr (i_out = fopnbf (Memc[devinfo], mode, zopnim, zardim, + zawrim, zawtim, zsttim, zclsim)) { + + call ttycdes (i_tty) + call erract (EA_ERROR) + } + call fseti (i_out, F_ADVICE, SEQUENTIAL) + + } + + # Initialize data structures. + # Device specific initialization will be done in the zinit call + # from ids_init(). + + if (!same_dev) { + call ids_init (i_tty, Memc[buf]) + + # Now set the file size to allow mapping of all control registers + # as well as all image and graphics planes. The call to fstatl + # returns the size of an image plane (!!). zinit does whatever + # device work it needs to do, and uses its arguments to determine + # the total file size, which it returns. + # This feature need not be used (and is not for the IIS display). + # + # We also set the F_ASYNC parameter to YES. + + i_frsize = fstatl(i_out, F_FILESIZE) + filesize = i_frsize + call zinit(i_maxframes, i_maxgraph, filesize) + call fseti(i_out, F_ASYNC, YES) + + } + + call sfree (sp) +end diff --git a/pkg/images/tv/iis/ids/idspcell.x b/pkg/images/tv/iis/ids/idspcell.x new file mode 100644 index 00000000..d678b286 --- /dev/null +++ b/pkg/images/tv/iis/ids/idspcell.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# number of grey scale symbols +define NSYMBOL 11 +define TSIZE (1.0/2.0) + +# IDS_PUTCELLARRAY -- Draw a cell array, i.e., two dimensional array of pixels +# (greylevels or colors). + +procedure ids_putcellarray (m, nc, nr, ax1,ay1, ax2,ay2) + +short m[ARB] # cell array +int nc, nr # number of pixels in X and Y + # (number of columns[x], rows[y] +int ax1, ay1 # lower left corner of output window +int ax2, ay2 # upper right corner of output window + +int x1,y1,x2,y2 +real px1, py1, px2, py2 +int nx, ny +real skip_x, skip_y, sx, sy +real blockx, blocky, bcy +int i, j, startrow, element +real xres, yres +pointer sp, cell +bool ca, use_orig, new_row + +include "../lib/ids.com" + +begin + # determine if can do real cell array. + + ca = (IDS_CELLARRAY(i_kt) != 0) + if ( !ca ) + return + + skip_x = 1.0 + skip_y = 1.0 + blockx = 1.0 + blocky = 1.0 + + xres = real(i_xres) + yres = real(i_yres) + + # adjust pixels for edges + x1 = ax1 + x2 = ax2 + y1 = ay1 + y2 = ay2 + call ids_cround(x1,x2,xres) + call ids_cround(y1,y2,yres) + + # find out how many real pixels we have to fill + + px1 = real(x1) * xres /(GKI_MAXNDC+1) + py1 = real(y1) * yres /(GKI_MAXNDC+1) + px2 = real(x2) * xres /(GKI_MAXNDC+1) + py2 = real(y2) * yres /(GKI_MAXNDC+1) + + nx = int( px2 ) - int( px1 ) + 1 + ny = int( py2 ) - int( py1 ) + 1 + + # if too many data points in input, set skip. If skip is close + # enough to one, set it to one. + # set block replication factors - will be > 1.0 if too few input points. + # cannot set to 1.0 if "close" enough, since, if > 1.0, we don't have + # enough points and so *some* have to be replicated. + + if ( nc > nx ) { + skip_x = real(nc)/nx + if ( (skip_x - 1.0)*(nx-1) < 1.0 ) + skip_x = 1.0 + } else + blockx = real(nx)/nc + + if ( nr > ny ) { + skip_y = real(nr)/ny + if ( (skip_y - 1.0)*(ny-1) < 1.0 ) + skip_y = 1.0 + } else + blocky = real(ny)/nr + + # initialize counters + + call smark(sp) + sy = skip_y + bcy = blocky + startrow = 1 + element = startrow + + # see if we can use original data ... no massaging + # also set the initial value of the new_row flag, which tells + # if we have to rebuild the row data + # note that if blockx > 1.0, skip_x must be 1.0, and vv + + if ( (skip_x == 1.0) && (blockx == 1.0) ) { + use_orig = true + new_row = false + } else { + use_orig = false + new_row = true + # allocate storage for a row of pixels. + call salloc ( cell, nx, TY_SHORT) + } + + # do it + + for ( i = 1; i <= ny ; i = i + 1) { + + # Build the row data. + + if (!use_orig && new_row) { + if ( skip_x == 1.0) + call ids_blockit(m[element], Mems[cell], nx, blockx) + else { + sx = skip_x + for ( j = 1; j <= nx; j = j + 1) { + Mems[cell+j-1] = m[element] + element = startrow + int(sx+0.5) + sx = sx + skip_x + } + } + } + + # Send the row data. The writing routine will figure out + # how to send to the various individual frames and bitplanes. + + call zseek (i_out, int(px1), int(py1)+i-1) + if (use_orig) + call write (i_out, m[element], nx) + else + call write (i_out, Mems[cell], nx) + + # Advance a row. + + element = startrow + if ( bcy <= real(i) ) { + startrow = 1 + nc * int(sy+0.5) + element = startrow + sy = sy + skip_y + bcy = bcy + blocky + new_row = true + } else { + new_row = false + } + } + + call sfree(sp) +end + + +# IDS_BLOCKIT -- block replication of data + +procedure ids_blockit( from, to, count, factor) + +short from[ARB] # input data +short to[ARB] # output data +int count # number of output pixels +real factor # blocking factor + +int i, j +real bc + +begin + bc = factor + j = 1 + for ( i = 1; i <= count ; i = i + 1 ) { + to[i] = from[j] + if ( bc <= real(i) ) { + j = j + 1 + bc = bc + factor + } + } +end diff --git a/pkg/images/tv/iis/ids/idspl.x b/pkg/images/tv/iis/ids/idspl.x new file mode 100644 index 00000000..77ac3bc3 --- /dev/null +++ b/pkg/images/tv/iis/ids/idspl.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# nspp particulars +# base width of line +define BASELW 8 + +# IDS_POLYLINE -- Draw a polyline. The polyline is defined by the array of +# points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure ids_polyline (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pl +int i, len_p +int linewidth + +include "../lib/ids.com" + +begin + if ( npts <= 0) + return + + len_p = npts * 2 + + # Update polyline attributes if necessary. + + pl = IDS_PLAP(i_kt) + + if (IDS_TYPE(i_kt) != PL_LTYPE(pl)) { + call ids_line(PL_LTYPE(pl)) + IDS_TYPE(i_kt) = PL_LTYPE(pl) + } + if (IDS_WIDTH(i_kt) != PL_WIDTH(pl)) { + linewidth = int(real(BASELW) * GKI_UNPACKREAL(PL_WIDTH(pl))) + i_linewidth = max(1,linewidth) + IDS_WIDTH(i_kt) = PL_WIDTH(pl) + } + if (IDS_COLOR(i_kt) != PL_COLOR(pl)) { + i_linecolor = PL_COLOR(pl) + IDS_COLOR(i_kt) = PL_COLOR(pl) + } + + # Move to the first point. point() will plot it, which is + # ok here, and vector may well plot it again. + + call ids_point(p[1], p[2], true) + + # Draw the polyline. + + for (i=3; i <= len_p; i=i+2) { + call ids_vector ( p[i], p[i+1]) + + } +end diff --git a/pkg/images/tv/iis/ids/idsplset.x b/pkg/images/tv/iis/ids/idsplset.x new file mode 100644 index 00000000..cf49ea1f --- /dev/null +++ b/pkg/images/tv/iis/ids/idsplset.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_PLSET -- Set the polyline attributes. The polyline width parameter is +# passed to the encoder as a packed floating point number, i.e., int(LWx100). + +procedure ids_plset (gki) + +short gki[ARB] # attribute structure +pointer pl + +include "../lib/ids.com" + +begin + pl = IDS_PLAP(i_kt) + PL_LTYPE(pl) = gki[GKI_PLSET_LT] + PL_WIDTH(pl) = gki[GKI_PLSET_LW] + PL_COLOR(pl) = gki[GKI_PLSET_CI] +end diff --git a/pkg/images/tv/iis/ids/idspm.x b/pkg/images/tv/iis/ids/idspm.x new file mode 100644 index 00000000..b165b7cc --- /dev/null +++ b/pkg/images/tv/iis/ids/idspm.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# nspp particulars +# base width of line +define BASELW 8 + +# IDS_POLYMARKER -- Draw a polymarker. The polymarker is defined by the array +# of points P, consisting of successive (x,y) coordinate pairs. The first point +# is not plotted but rather defines the start of the polyline. The remaining +# points define line segments to be drawn. + +procedure ids_polymarker (p, npts) + +short p[ARB] # points defining line +int npts # number of points, i.e., (x,y) pairs + +pointer pm +int i, len_p +int linewidth +short x,y + +include "../lib/ids.com" + +begin + if ( npts <= 0) + return + + len_p = npts * 2 + + # Update polymarker attributes if necessary. + + pm = IDS_PMAP(i_kt) + + if (IDS_TYPE(i_kt) != PM_LTYPE(pm)) { + call ids_line(PM_LTYPE(pm)) + IDS_TYPE(i_kt) = PM_LTYPE(pm) + } + if (IDS_WIDTH(i_kt) != PM_WIDTH(pm)) { + linewidth = int(real(BASELW) * GKI_UNPACKREAL(PM_WIDTH(pm))) + i_linewidth = max(1,linewidth) + IDS_WIDTH(i_kt) = PM_WIDTH(pm) + } + if (IDS_COLOR(i_kt) != PM_COLOR(pm)) { + i_linecolor = PM_COLOR(pm) + IDS_COLOR(i_kt) = PM_COLOR(pm) + } + + for (i=1; i <= len_p; i=i+2) { + x = p[i] + y = p[i+1] + call ids_point (real(x)/GKI_MAXNDC, real(y)/GKI_MAXNDC, true) + } +end diff --git a/pkg/images/tv/iis/ids/idspmset.x b/pkg/images/tv/iis/ids/idspmset.x new file mode 100644 index 00000000..be46ede8 --- /dev/null +++ b/pkg/images/tv/iis/ids/idspmset.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# IDS_PMSET -- Set the polymarker attributes. + +procedure ids_pmset (gki) + +short gki[ARB] # attribute structure +pointer pm +include "../lib/ids.com" + +begin + pm = IDS_PMAP(i_kt) + PM_LTYPE(pm) = gki[GKI_PMSET_MT] + PM_WIDTH(pm) = gki[GKI_PMSET_MW] + PM_COLOR(pm) = gki[GKI_PMSET_CI] +end diff --git a/pkg/images/tv/iis/ids/idspoint.x b/pkg/images/tv/iis/ids/idspoint.x new file mode 100644 index 00000000..2addb635 --- /dev/null +++ b/pkg/images/tv/iis/ids/idspoint.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# IDS_POINT -- Plot a point in the current plane at given (GKI) coordinates. + +procedure ids_point (ax,ay,flag) + +short ax,ay # point coordinates, GKI +bool flag # true if should plot point, false if just a + # pen move +int xp, yp +int bufsize +int fstati() + +include "../lib/ids.com" + +begin + # convert to device coords, plot max value, then record in i_pt + xp = real(ax) * i_xres /(GKI_MAXNDC+1) + yp = real(ay) * i_yres /(GKI_MAXNDC+1) + + # if flag is true, we plot the point. If false, we just want + # to record the points (a pen move), so skip the plot commands + + if (flag) { + # set buffer to size one + bufsize = fstati (i_out, F_BUFSIZE) + call fseti (i_out, F_BUFSIZE, 1) + + # plot it + call zseek (i_out, xp, yp) + call write(i_out, short(IDS_ZRES(i_kt)-1), 1) + + # restore buffer + call fseti (i_out, F_BUFSIZE, bufsize) + } + i_pt_x = xp + i_pt_y = yp +end + + +# IDS_RPOINT - Plot a point in the current plane at given (device coord) offsets +# from current point. + +procedure ids_rpoint (dx,dy) + +short dx,dy # DEVICE coordinate increments from cur. pos. + +int xp, yp + +include "../lib/ids.com" + +begin + xp = i_pt_x + dx + yp = i_pt_y + dy + + call zseek (i_out, xp, yp) + call write(i_out, short(IDS_ZRES(i_kt)-1), 1) + + i_pt_x = xp + i_pt_y = yp +end diff --git a/pkg/images/tv/iis/ids/idsreset.x b/pkg/images/tv/iis/ids/idsreset.x new file mode 100644 index 00000000..627b3d4e --- /dev/null +++ b/pkg/images/tv/iis/ids/idsreset.x @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# IDS_RESET -- Reset the state of the transform common, i.e., in response to +# a clear or a cancel. Initialize all attribute packets to their default +# values and set the current state of the device to undefined, forcing the +# device state to be reset when the next output instruction is executed. +# Clear the image, graphics, and luts only if reset is "hard" enough. + +procedure ids_reset(hardness) + +short hardness + +pointer pl, pm, fa, tx + +include "../lib/ids.com" + +begin + # Set pointers to attribute substructures. + pl = IDS_PLAP(i_kt) + pm = IDS_PMAP(i_kt) + fa = IDS_FAAP(i_kt) + tx = IDS_TXAP(i_kt) + + # Initialize the attribute packets. + PL_LTYPE(pl) = 1 + PL_WIDTH(pl) = GKI_PACKREAL(1.) + PL_COLOR(pl) = 1 + PM_LTYPE(pm) = 1 + PM_WIDTH(pm) = GKI_PACKREAL(1.) + PM_COLOR(pm) = 1 + FA_STYLE(fa) = 1 + FA_COLOR(fa) = 1 + TX_UP(tx) = 90 + TX_SIZE(tx) = GKI_PACKREAL(1.) + TX_PATH(tx) = GT_RIGHT + TX_HJUSTIFY(tx) = GT_LEFT + TX_VJUSTIFY(tx) = GT_BOTTOM + TX_FONT(tx) = GT_ROMAN + TX_COLOR(tx) = 1 + TX_SPACING(tx) = 0.0 + + # Set the device attributes to undefined, forcing them to be reset + # when the next output instruction is executed. + + IDS_TYPE(i_kt) = -1 + IDS_WIDTH(i_kt) = -1 + IDS_COLOR(i_kt) = -1 + IDS_TXSIZE(i_kt) = -1 + IDS_TXFONT(i_kt) = -1 + + call zreset(hardness) +end diff --git a/pkg/images/tv/iis/ids/idsrestore.x b/pkg/images/tv/iis/ids/idsrestore.x new file mode 100644 index 00000000..246631c0 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsrestore.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_RESTORE -- Restore the control state of the display, together with +# zero to all of the image and graphics planes. + +procedure ids_restore (data, n) + +short data[ARB] # instruction data words +short n # number of data words + +int fd # binary file output descriptor +short i, j +short frame[IDS_MAXIMPL+1] # frames to save +short graph[IDS_MAXGRPL+1] # graph planes to save +short buffer[IDS_MAXDATA] # for data storage + +include "../lib/ids.com" + +begin + # determine file descriptor to read (opened by upper end) + # ( assume upper end has retrieved whatever data it stored and + # leaves fd pointing at control information offset) + # then retrieve the frame data + + fd = data[1] + + # image data + + call read(fd, i, SZ_SHORT) + call read(fd, buffer, i) + j = 0 + i = 0 + repeat { + i = i + 1 + j = j + 1 + frame[j] = buffer[i] + } until ( (buffer[i] == IDS_EOD) || ( j == i_maxframes) ) + frame[i+1] = IDS_EOD + + # graph data + + call read(fd, i, SZ_SHORT) + call read(fd, buffer, i) + i = 0 + j = 0 + repeat { + i = i + 1 + j = j + 1 + graph[j] = buffer[i] + } until ( (buffer[i] == IDS_EOD) || ( j == i_maxgraph) ) + graph[i+1] = IDS_EOD + + # get all control information + + call zdev_restore(fd) + + # get image data + + if ( frame[1] == IDS_EOD) { + for ( i = 1 ; i <= i_maxframes ; i = i + 1) + frame[i] = i + frame[i+1] = IDS_EOD + } + if ( frame[1] != 0 ) { + for ( i = 1 ; frame[i] != IDS_EOD ; i = i + 1) + call zim_restore (fd, frame[i]) + } + + # get graphics data + + if ( graph[1] == IDS_EOD) { + for ( i = 1 ; i <= i_maxgraph ; i = i + 1) + graph[i] = i + graph[i+1] = IDS_EOD + } + if ( graph[1] != 0 ) { + for ( i = 1 ; graph[i] != IDS_EOD ; i = i + 1) + call zgr_restore (fd, graph[i]) + } + + # upper end to close file +end diff --git a/pkg/images/tv/iis/ids/idssave.x b/pkg/images/tv/iis/ids/idssave.x new file mode 100644 index 00000000..a66ebc00 --- /dev/null +++ b/pkg/images/tv/iis/ids/idssave.x @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_SAVE -- Save the control state of the display, together with +# zero to all of the image and graphics planes. + +procedure ids_save (data, n) + +short data[ARB] # instruction data words +short n # count of data words + +int fd # binary file output descriptor +short i, j +short frame[IDS_MAXIMPL+1] # frames to save +short graph[IDS_MAXGRPL+1] # graph planes to save + +include "../lib/ids.com" + +begin + # do we need to check n ?? + + # determine file descriptor to write (opened by upper end) + # ( assume upper end has saved whatever data it wanted and + # leaves fd pointing at control information offset) + # then squirrel away the frame data + + fd = data[1] + + # image data + + i = 1 + j = 0 + repeat { + i = i + 1 + j = j + 1 + frame[j] = data[i] + } until ( data[i] == IDS_EOD ) + call write(fd, j, SZ_SHORT) + call write(fd, frame[1], j*SZ_SHORT) + + # graph data + + j = 0 + repeat { + i = i + 1 + j = j + 1 + graph[j] = data[i] + } until ( data[i] == IDS_EOD ) + call write(fd, j, SZ_SHORT) + call write(fd, graph[1], j*SZ_SHORT) + + # get all control information + + call zdev_save(fd) + + # get image data + + if ( frame[1] == IDS_EOD) { + for ( i = 1 ; i <= i_maxframes ; i = i + 1) + frame[i] = i + frame[i+1] = IDS_EOD + } + if ( frame[1] != 0 ) { + for ( i = 1 ; frame[i] != IDS_EOD ; i = i + 1) + call zim_save (fd, frame[i]) + } + + # get graphics data + + if ( graph[1] == IDS_EOD) { + for ( i = 1 ; i <= i_maxgraph ; i = i + 1) + graph[i] = i + graph[i+1] = IDS_EOD + } + if ( graph[1] != 0 ) { + for ( i = 1 ; graph[i] != IDS_EOD ; i = i + 1) + call zgr_save (fd, graph[i]) + } + + # upper end to close file +end diff --git a/pkg/images/tv/iis/ids/idsscur.x b/pkg/images/tv/iis/ids/idsscur.x new file mode 100644 index 00000000..7ec48c32 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsscur.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IDS_SETCURSOR -- Set the position of a cursor. + +procedure ids_setcursor (x, y, cursor) + +int x, y # new position of cursor +int cursor # cursor to be set + +begin + call zcursor_set(cursor, x, y) +end diff --git a/pkg/images/tv/iis/ids/idsstream.x b/pkg/images/tv/iis/ids/idsstream.x new file mode 100644 index 00000000..bb7360b4 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsstream.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IDS_GRSTREAM -- Set the FD of the graphics/image stream, to which +# we return cell arrays and cursor values. + +procedure ids_grstream (stream) + +int stream + +include "../lib/ids.com" + +begin + i_in = stream +end diff --git a/pkg/images/tv/iis/ids/idstx.x b/pkg/images/tv/iis/ids/idstx.x new file mode 100644 index 00000000..7209d00b --- /dev/null +++ b/pkg/images/tv/iis/ids/idstx.x @@ -0,0 +1,428 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +define BASECS_X 12 # Base (size 1.0) char width in GKI coords. +define BASECS_Y 12 # Base (size 1.0) char height in GKI coords. + + +# IDS_TEXT -- Draw a text string. The string is drawn at the position (X,Y) +# using the text attributes set by the last GKI_TXSET instruction. The text +# string to be drawn may contain embedded set font escape sequences of the +# form \fR (roman), \fG (greek), etc. We break the input text sequence up +# into segments at font boundaries and draw these on the output device, +# setting the text size, color, font, and position at the beginning of each +# segment. + +procedure ids_text (xc, yc, text, n) + +int xc, yc # where to draw text string +short text[ARB] # text string +int n # number of characters + +real x, y, dx, dy, tsz +int x1, x2, y1, y2, orien +int x0, y0, ids_dx, ids_dy, ch, cw +int xstart, ystart, newx, newy +int totlen, polytext, font, seglen +pointer sp, seg, ip, op, tx, first +int stx_segment() + +include "../lib/ids.com" + +real i_dx, i_dy # scale GKI to window coords +int i_x1, i_y1 # origin of device window +int i_x2, i_y2 # upper right corner of device window +data i_dx /1.0/, i_dy /1.0/ +data i_x1 /0/, i_y1 /0/, i_x2 /GKI_MAXNDC/, i_y2 / GKI_MAXNDC/ + +begin + call smark (sp) + call salloc (seg, n + 2, TY_CHAR) + + # Set pointer to the text attribute structure. + tx = IDS_TXAP(i_kt) + + # Set the text size and color if not already set. Both should be + # invalidated when the screen is cleared. Text color should be + # invalidated whenever another color is set. The text size was + # set by ids_txset, and is just a scaling factor. + + IDS_TXSIZE(i_kt) = TX_SIZE(tx) + # For display, have 32767 sizes, so just scale the the base sizes. + tsz = GKI_UNPACKREAL(TX_SIZE(tx)) # scale factor + ch = IDS_CHARHEIGHT(i_kt,1) * tsz + cw = IDS_CHARWIDTH(i_kt,1) * tsz + + if (TX_COLOR(tx) != IDS_COLOR(i_kt)) { + # Should do something like call ids_color (TX_COLOR(tx)) + # But that requires some association of color with hardware + # and what that should be is not clear. + IDS_COLOR(i_kt) = TX_COLOR(tx) + } + + # Set the linetype to a solid line, and invalidate last setting. + call ids_linetype (GL_SOLID) + IDS_TYPE(i_kt) = -1 + + # Break the text string into segments at font boundaries and count + # the total number of printable characters. + + totlen = stx_segment (text, n, Memc[seg], TX_FONT(tx)) + + # Compute the text drawing parameters, i.e., the coordinates of the + # first character to be drawn, the step between successive characters, + # and the polytext flag (GKI coords). + + call stx_parameters (xc,yc, totlen, x0,y0, ids_dx,ids_dy, polytext, + orien) + + # Draw the segments, setting the font at the beginning of each segment. + # The first segment is drawn at (X0,Y0). The separation between + # characters is DX,DY. A segment is drawn as a block if the polytext + # flag is set, otherwise each character is drawn individually. + + x = x0 * i_dx + i_x1 + y = y0 * i_dy + i_y1 + dx = ids_dx * i_dx + dy = ids_dy * i_dy + + for (ip=seg; Memc[ip] != EOS; ip=ip+1) { + # Process the font control character heading the next segment. + font = Memc[ip] + ip = ip + 1 + + # Draw the segment. + while (Memc[ip] != EOS) { + # Clip leading out of bounds characters. + for (; Memc[ip] != EOS; ip=ip+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 >= i_x1 && x2 <= i_x2 && y1 >= i_y1 && y2 <= i_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + ip = ip + 1 + break + } + } + + # Coords of first char to be drawn. + xstart = x + ystart = y + + # Move OP to first out of bounds char. + for (op=ip; Memc[op] != EOS; op=op+1) { + x1 = x; x2 = x1 + cw + y1 = y; y2 = y1 + ch + + if (x1 <= i_x1 || x2 >= i_x2 || y1 <= i_y1 || y2 >= i_y2) + break + else { + x = x + dx + y = y + dy + } + + if (polytext == NO) { + op = op + 1 + break + } + } + + # Count number of inbounds chars. + seglen = op - ip + + # Leave OP pointing to the end of this segment. + if (polytext == NO) + op = ip + 1 + else { + while (Memc[op] != EOS) + op = op + 1 + } + + # Compute X,Y of next segment. + newx = xstart + (dx * (op - ip)) + newy = ystart + dy + + # Quit if no inbounds chars. + if (seglen == 0) { + x = newx + y = newy + ip = op + next + } + + # Output the inbounds chars. + + first = ip + x = xstart + y = ystart + + while (seglen > 0 && (polytext == YES || ip == first)) { + call ids_drawchar (Memc[ip], nint(x), nint(y), cw, ch, + orien, font) + ip = ip + 1 + seglen = seglen - 1 + x = x + dx + y = y + dy + } + + x = newx + y = newy + ip = op + } + } + + call sfree (sp) +end + + +# STX_SEGMENT -- Process the text string into segments, in the process +# converting from type short to char. The only text attribute that can +# change within a string is the font, so segments are broken by \fI, \fG, +# etc. font select sequences embedded in the text. The segments are encoded +# sequentially in the output string. The first character of each segment is +# the font number. A segment is delimited by EOS. A font number of EOS +# marks the end of the segment list. The output string is assumed to be +# large enough to hold the segmented text string. + +int procedure stx_segment (text, n, out, start_font) + +short text[ARB] # input text +int n # number of characters in text +char out[ARB] # output string +int start_font # initial font code + +int ip, op +int totlen, font + +begin + out[1] = start_font + totlen = 0 + op = 2 + + for (ip=1; ip <= n; ip=ip+1) { + if (text[ip] == '\\' && text[ip+1] == 'f') { + # Select font. + out[op] = EOS + op = op + 1 + ip = ip + 2 + + switch (text[ip]) { + case 'B': + font = GT_BOLD + case 'I': + font = GT_ITALIC + case 'G': + font = GT_GREEK + default: + font = GT_ROMAN + } + + out[op] = font + op = op + 1 + + } else { + # Deposit character in segment. + out[op] = text[ip] + op = op + 1 + totlen = totlen + 1 + } + } + + # Terminate last segment and add null segment. + + out[op] = EOS + out[op+1] = EOS + + return (totlen) +end + + +# STX_PARAMETERS -- Set the text drawing parameters, i.e., the coordinates +# of the lower left corner of the first character to be drawn, the spacing +# between characters, and the polytext flag. Input consists of the coords +# of the text string, the length of the string, and the text attributes +# defining the character size, justification in X and Y of the coordinates, +# and orientation of the string. All coordinates are in GKI units. + +procedure stx_parameters (xc, yc, totlen, x0, y0, dx, dy, polytext, orien) + +int xc, yc # coordinates at which string is to be drawn +int totlen # number of characters to be drawn +int x0, y0 # lower left corner of first char to be drawn +int dx, dy # step in X and Y between characters +int polytext # OK to output text segment all at once +int orien # rotation angle of characters + +pointer tx +int up, path +real dir, ch, cw, cosv, sinv, space, sz +real xsize, ysize, xvlen, yvlen, xu, yu, xv, yv, p, q + +include "../lib/ids.com" + +begin + tx = IDS_TXAP(i_kt) + + # Get character sizes in GKI coords. + sz = GKI_UNPACKREAL (TX_SIZE(tx)) + ch = IDS_CHARHEIGHT(i_kt,1) * sz + cw = IDS_CHARWIDTH(i_kt,1) * sz + + # Compute the character rotation angle. This is independent of the + # direction in which characters are drawn. A character up vector of + # 90 degrees (normal) corresponds to a rotation angle of zero. + + up = TX_UP(tx) + orien = up - 90 + + # Determine the direction in which characters are to be plotted. + # This depends on both the character up vector and the path, which + # is defined relative to the up vector. + + path = TX_PATH(tx) + switch (path) { + case GT_UP: + dir = up + case GT_DOWN: + dir = up - 180 + case GT_LEFT: + dir = up + 90 + default: # GT_NORMAL, GT_RIGHT + dir = up - 90 + } + + # ------- DX, DY --------- + # Convert the direction vector into the step size between characters. + # Note CW and CH are in GKI coordinates, hence DX and DY are too. + # Additional spacing of some fraction of the character size is used + # if TX_SPACING is nonzero. + + dir = -DEGTORAD(dir) + cosv = cos (dir) + sinv = sin (dir) + + # Correct for spacing (unrotated). + space = (1.0 + TX_SPACING(tx)) + if (path == GT_UP || path == GT_DOWN) + p = ch * space + else + p = cw * space + q = 0 + + # Correct for rotation. + dx = p * cosv + q * sinv + dy = -p * sinv + q * cosv + + # ------- XU, YU --------- + # Determine the coordinates of the center of the first character req'd + # to justify the string, assuming dimensionless characters spaced on + # centers DX,DY apart. + + xvlen = dx * (totlen - 1) + yvlen = dy * (totlen - 1) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xu = - (xvlen / 2.0) + case GT_RIGHT: + # If right justify and drawing to the left, no offset req'd. + if (xvlen < 0) + xu = 0 + else + xu = -xvlen + default: # GT_LEFT, GT_NORMAL + # If left justify and drawing to the left, full offset right req'd. + if (xvlen < 0) + xu = -xvlen + else + xu = 0 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yu = - (yvlen / 2.0) + case GT_TOP: + # If top justify and drawing downward, no offset req'd. + if (yvlen < 0) + yu = 0 + else + yu = -yvlen + default: # GT_BOTTOM, GT_NORMAL + # If bottom justify and drawing downward, full offset up req'd. + if (yvlen < 0) + yu = -yvlen + else + yu = 0 + } + + # ------- XV, YV --------- + # Compute the offset from the center of a single character required + # to justify that character, given a particular character up vector. + # (This could be combined with the above case but is clearer if + # treated separately.) + + p = -DEGTORAD(orien) + cosv = cos(p) + sinv = sin(p) + + # Compute the rotated character in size X and Y. + xsize = abs ( cw * cosv + ch * sinv) + ysize = abs (-cw * sinv + ch * cosv) + + switch (TX_HJUSTIFY(tx)) { + case GT_CENTER: + xv = 0 + case GT_RIGHT: + xv = - (xsize / 2.0) + default: # GT_LEFT, GT_NORMAL + xv = xsize / 2 + } + + switch (TX_VJUSTIFY(tx)) { + case GT_CENTER: + yv = 0 + case GT_TOP: + yv = - (ysize / 2.0) + default: # GT_BOTTOM, GT_NORMAL + yv = ysize / 2 + } + + # ------- X0, Y0 --------- + # The center coordinates of the first character to be drawn are given + # by the reference position plus the string justification vector plus + # the character justification vector. + + x0 = xc + xu + xv + y0 = yc + yu + yv + + # The character drawing primitive requires the coordinates of the + # lower left corner of the character (irrespective of orientation). + # Compute the vector from the center of a character to the lower left + # corner of a character, rotate to the given orientation, and correct + # the starting coordinates by addition of this vector. + + p = - (cw / 2.0) + q = - (ch / 2.0) + + x0 = x0 + ( p * cosv + q * sinv) + y0 = y0 + (-p * sinv + q * cosv) + + # ------- POLYTEXT --------- + # Set the polytext flag. Polytext output is possible only if chars + # are to be drawn to the right with no extra spacing between chars. + + if (abs(dy) == 0 && dx == cw) + polytext = YES + else + polytext = NO +end diff --git a/pkg/images/tv/iis/ids/idstxset.x b/pkg/images/tv/iis/ids/idstxset.x new file mode 100644 index 00000000..3c9529da --- /dev/null +++ b/pkg/images/tv/iis/ids/idstxset.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# IDS_TXSET -- Set the text drawing attributes. + +procedure ids_txset (gki) + +short gki[ARB] # attribute structure + +pointer tx + +include "../lib/ids.com" + +begin + tx = IDS_TXAP(i_kt) + TX_UP(tx) = gki[GKI_TXSET_UP] + TX_PATH(tx) = gki[GKI_TXSET_P ] + TX_HJUSTIFY(tx) = gki[GKI_TXSET_HJ] + TX_VJUSTIFY(tx) = gki[GKI_TXSET_VJ] + TX_FONT(tx) = gki[GKI_TXSET_F ] + TX_QUALITY(tx) = gki[GKI_TXSET_Q ] + TX_COLOR(tx) = gki[GKI_TXSET_CI] + + TX_SPACING(tx) = GKI_UNPACKREAL (gki[GKI_TXSET_SP]) + TX_SIZE(tx) = gki[GKI_TXSET_SZ] + +end diff --git a/pkg/images/tv/iis/ids/idsvector.x b/pkg/images/tv/iis/ids/idsvector.x new file mode 100644 index 00000000..6d1ec502 --- /dev/null +++ b/pkg/images/tv/iis/ids/idsvector.x @@ -0,0 +1,122 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +define MAXC 10000 # just a largish int here + +# IDS_VECTOR -- Plot a line in the current plane; the starting coordinates +# are in ids.com: i_pt_x, i_pt_y. The end points are the arguments +# to vector. +# the code is Bresenham's algorithm, as taken from the line drawing +# routine in Forth-11 image display code. + +procedure ids_vector (ax,ay) + +short ax,ay # vector end coordinates, GKI + +short x,y +short xe ,ye # end coordinates, device +short dx,dy,dd +short xi,yi, xid,yid # increments +short total, e # total change and error +int bufsize # file i/o buffersize +int fstati() +int count, cmax + +include "../lib/ids.com" + +begin + x = ax + y = ay + + bufsize = fstati(i_out, F_BUFSIZE) + + # convert x,y to device coords. + xe = real(x) * i_xres /(GKI_MAXNDC+1) + ye = real(y) * i_yres /(GKI_MAXNDC+1) + + # determine delta x and y, and x/y increments + + dx = xe - i_pt_x + dy = ye - i_pt_y + + # set movement increments, take absolute value of dx, dy + if ( dy >= 0 ) + yi = 1 + else { + yi = -1 + dy = -dy + } + if ( dx >= 0 ) + xi = 1 + else { + xi = -1 + dx = -dx + } + + # set diagonal movement increments + xid = xi + yid = yi + + # if, for instance, pos. slope less than 45 degrees, most movement + # is in x, so then set (the ususal) y increment to zero + if ( dy >= dx ) + xi = 0 + else + yi = 0 + + # Set up for buffer of one, and let code find best buffering + cmax = 0 + call fseti(i_out, F_BUFSIZE, 1) + count = 0 + + # Plot the first point + call ids_rpoint (0, 0) + + # Is there anything to do? determine total increments to plot; if + # zero, quit + total = dx + dy + if ( total == 0 ) { + call fseti (i_out, F_BUFSIZE, bufsize) + return + } + + # set error to zero, determine difference in x,y change. + e = 0 + dd = dy - dx + if ( dd >= 0 ) { + dd = -dd + dy = dx + } + + # plot the line + repeat { + dx = dd + e + if ( (dy + e + dx) >= 0 ) { + # diagonal plot, accounts for two units of increment + if ( count > cmax ) { + # leaving current (x) line, so determine how many points + # have plotted on line and use this (maximum) as line + # buffering size + call fseti(i_out, F_BUFSIZE, count) + cmax = count + count = 0 + } + call ids_rpoint ( xid, yid ) + total = total - 2 + e = dx + } else { + # move in x (or y) only; for the small positive slope line, + # real line will move up and finally over line being plotted, + # hence e increases. + call ids_rpoint ( xi, yi ) + total = total - 1 + e = e + dy + count = count + 1 + } + } until ( total <= 0 ) + # restore original buffer size + call fseti(i_out, F_BUFSIZE, bufsize) +end diff --git a/pkg/images/tv/iis/ids/mkpkg b/pkg/images/tv/iis/ids/mkpkg new file mode 100644 index 00000000..79778100 --- /dev/null +++ b/pkg/images/tv/iis/ids/mkpkg @@ -0,0 +1,43 @@ +# Make the CV package library. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + idscancel.x ../lib/ids.com ../lib/ids.h + idschars.x ../lib/ids.com ../lib/ids.h + idsclear.x ../lib/ids.com ../lib/ids.h + idsclose.x ../lib/ids.com ../lib/ids.h + idsclosews.x ../lib/ids.h ../lib/ids.com + idscround.x ../lib/ids.h + idsdrawch.x font.com font.h + idsescape.x ../lib/ids.com ../lib/ids.h + idsfa.x ../lib/ids.com ../lib/ids.h + idsfaset.x ../lib/ids.com ../lib/ids.h + idsflush.x ../lib/ids.com ../lib/ids.h + idsfont.x ../lib/ids.com ../lib/ids.h + idsgcell.x ../lib/ids.com ../lib/ids.h + idsgcur.x ../lib/ids.com ../lib/ids.h + idsinit.x ../lib/ids.com ../lib/ids.h + idsline.x ../lib/ids.com ../lib/ids.h + idslutfill.x + idsopen.x ../lib/ids.com ../lib/ids.h + idsopenws.x ../lib/ids.com ../lib/ids.h \ + + idspcell.x ../lib/ids.com ../lib/ids.h + idspl.x ../lib/ids.com ../lib/ids.h + idsplset.x ../lib/ids.com ../lib/ids.h + idspm.x ../lib/ids.com ../lib/ids.h + idspmset.x ../lib/ids.com ../lib/ids.h + idspoint.x ../lib/ids.com ../lib/ids.h + idsreset.x ../lib/ids.com ../lib/ids.h + idsrestore.x ../lib/ids.com ../lib/ids.h + idssave.x ../lib/ids.com ../lib/ids.h + idsscur.x + idsstream.x ../lib/ids.com ../lib/ids.h + idstx.x ../lib/ids.com ../lib/ids.h + idstxset.x ../lib/ids.com ../lib/ids.h + idsvector.x ../lib/ids.com ../lib/ids.h + ; diff --git a/pkg/images/tv/iis/ids/testcode/README b/pkg/images/tv/iis/ids/testcode/README new file mode 100644 index 00000000..31198b43 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/README @@ -0,0 +1,2 @@ +This is junk code which I think should be thrown away. I will leave it here +for the time just in case. (LED 22/4/91) diff --git a/pkg/images/tv/iis/ids/testcode/box.x b/pkg/images/tv/iis/ids/testcode/box.x new file mode 100644 index 00000000..e3c1d22b --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/box.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# create a box test image + +procedure t_im() + +pointer gp +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int fd + +pointer gopen() +bool streq() +int open() + +short i,data[DIM+1] +short set_image[6] +int key +real x[30],y[30] +real lb,ub,mid +int mod() + +begin + call clgstr("output", output, SZ_FNAME) + if (!streq (output, "") ) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$stdimage", NEW_FILE, BINARY_FILE) + + call clgstr("device", device, SZ_FNAME) + gp = gopen ( device, NEW_FILE, fd) + + # now set up boxes + set_image[1] = 1 + set_image[2] = IMD_EOD + set_image[3] = IMD_BLUE + set_image[4] = IMD_EOD + call gescape ( gp, IMD_SET_GP, set_image, 4) + lb = 0.0 + ub = 1.0 + mid = (lb + ub)/2. + for ( i = 1; i <= 5 ; i = i + 1 ) { + if ( mod(i-1,2) == 0 ) { + x[1] = lb + y[1] = mid + x[2] = mid + y[2] = ub + x[3] = ub + y[3] = mid + x[4] = mid + y[4] = lb + x[5] = lb + y[5] = mid + } else { + x[1] = (mid-lb)/2 + lb + y[1] = x[1] + x[2] = x[1] + # x[2] = x[1] - .05 + y[2] = y[1] + mid - lb + x[3] = y[2] + y[3] = y[2] + # y[3] = y[2] - .05 + x[4] = y[2] + y[4] = x[1] + x[5] = x[1] + y[5] = y[1] + lb = x[1] + ub = y[2] + } + call gpline ( gp, x, y, 5) + } + + # all done + call gclose ( gp ) + call close ( fd ) +end diff --git a/pkg/images/tv/iis/ids/testcode/boxin.x b/pkg/images/tv/iis/ids/testcode/boxin.x new file mode 100644 index 00000000..e854935f --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/boxin.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ids.h" +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# create a box test image + +procedure t_im() + +pointer gp +char device[SZ_FNAME] + +pointer gopen() +int dd[LEN_GKIDD] + +short i,data[DIM+1] +short set_image[6] +int key, j +real x[30],y[30] +real lb,ub,mid +int mod() + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + + # enable the blue plane + set_image[1] = IDS_ON + set_image[2] = IDS_EOD # all graphics frames + set_image[3] = IDS_BLUE # color + set_image[4] = IDS_EOD + set_image[5] = IDS_EOD # all quadrants + call gescape ( gp, IDS_DISPLAY_G, set_image, 5) + + # set which plane to write into + set_image[1] = 1 + set_image[2] = IDS_EOD # first graphics frame + set_image[3] = IDS_BLUE # color + set_image[4] = IDS_EOD + call gescape ( gp, IDS_SET_GP, set_image, 4) + + # now set up boxes + lb = 0.0 + ub = 1.0 + mid = (lb + ub)/2. + for ( i = 1; i <= 5 ; i = i + 1 ) { + if ( mod(i-1,2) == 0 ) { + x[1] = lb + y[1] = mid + x[2] = mid + y[2] = ub + x[3] = ub + y[3] = mid + x[4] = mid + y[4] = lb + x[5] = lb + y[5] = mid + } else { + x[1] = (mid-lb)/2 + lb + y[1] = x[1] + x[2] = x[1] + y[2] = y[1] + mid - lb + x[3] = y[2] + y[3] = y[2] + x[4] = y[2] + y[4] = x[1] + x[5] = x[1] + y[5] = y[1] + lb = x[1] + ub = y[2] + } + do j = 1,5 { + x[j] = x[j] * 32768. / 32767. + if (x[j] > 1.0) + x[j] = 1.0 + y[j] = y[j] * 32768. / 32767. + if (y[j] > 1.0) + y[j] = 1.0 + } + call gpline ( gp, x, y, 5) + } + + # all done + call gclose ( gp ) + call ids_close +end diff --git a/pkg/images/tv/iis/ids/testcode/crin.x b/pkg/images/tv/iis/ids/testcode/crin.x new file mode 100644 index 00000000..c9d27279 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/crin.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ids.h" +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# zoom + +procedure t_im() + +pointer gp +char device[SZ_FNAME] + +pointer gopen() +int dd[LEN_GKIDD] + +short i, data[DIM+1] +int key, but, fnum +real x, y +real xjunk, yjunk + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + # read first to clear box + call gseti(gp, G_CURSOR, IDS_BUT_RD) + call ggcur(gp, xjunk, yjunk, key) + + i = 1 + repeat { + call eprintf("set zoom and zoom center\n") + call gseti (gp, G_CURSOR, IDS_BUT_WT) + call ggcur(gp, x, y, but) + call gseti (gp, G_CURSOR, 1) + call ggcur(gp, x, y, key) + call zm(gp, but, x, y) + call eprintf("set frame, 4 to exit\n") + call gseti (gp, G_CURSOR, IDS_BUT_WT) + call ggcur(gp, xjunk, yjunk, fnum) + if ( fnum == 4) + break + call iset(gp, fnum) + repeat { + call gseti (gp, G_CURSOR, IDS_BUT_WT) + call ggcur(gp, xjunk, yjunk, but) + call gseti (gp, G_CURSOR, fnum) + call rpc(gp, x, y, key) + call ggcell (gp, data, 1, 1, x, y, x, y) + call eprintf("frame %d, datum: %d\n") + call pargi (fnum) + call pargs (data[1]) + } until ( but == 4) + } until ( i == 0 ) + + + # all done + call gclose ( gp ) + call ids_close +end + +# rpcursor --- read and print cursor + +procedure rpc(gp, sx, sy, key) + +pointer gp +real sx,sy +int key + +begin + call ggcur (gp, sx, sy, key) + call eprintf("cursor: (%f,%f) (%d,%d) key %d\n") + call pargr (sx) + call pargr (sy) + call pargi ( int(sx*32767)/64) + call pargi ( int(sy*32767)/64) + call pargi (key) +end + +# zoom + +procedure zm(gp, pow, x, y) + +int pow +pointer gp +real x, y + +short data[9] + +begin + data[1] = IDS_ZOOM + data[2] = IDS_WRITE + data[3] = 3 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = 2**(pow-1) + data[8] = x * GKI_MAXNDC + data[9] = y * GKI_MAXNDC + call gescape ( gp, IDS_CONTROL, data[1], 9) +end + +# set image plane for operation + +procedure iset (gp, frame) + +int frame +pointer gp + +short data[10] + +begin + data[1] = frame + data[2] = IDS_EOD + data[3] = IDS_EOD # all bitplanes + call gescape (gp, IDS_SET_IP, data, 3) +end diff --git a/pkg/images/tv/iis/ids/testcode/grey.x b/pkg/images/tv/iis/ids/testcode/grey.x new file mode 100644 index 00000000..a7e16b83 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/grey.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# create a grey scale test image, using frames 1 and 2, and +# position the cursor in the upper right quadrant. + +procedure t_im() + +pointer gp +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int fd + +pointer gopen() +bool streq() +int open() + +short i,data[DIM+1] +short display[6] +short set_image[3] +real y, sx, sy +int key + +begin + call clgstr("output", output, SZ_FNAME) + if (!streq (output, "") ) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$stdimage", NEW_FILE, BINARY_FILE) + + call clgstr("device", device, SZ_FNAME) + gp = gopen ( device, NEW_FILE, fd) + + data[1] = IMD_R_HARD + call gescape ( gp, IMD_RESET, data, 1) + # display all frames off + display[1] = IMD_OFF + display[2] = IMD_EOD # all frames + display[3] = IMD_EOD # all colors + display[4] = IMD_EOD # all quads + call gescape ( gp, IMD_DISPLAY_I, display, 6) + # display frames 1, 2 on -- 1 red, 2 green + display[1] = IMD_ON + display[2] = 1 + display[3] = IMD_EOD + display[4] = IMD_RED + display[5] = IMD_EOD + display[6] = IMD_EOD # all quads + call gescape ( gp, IMD_DISPLAY_I, display, 6) + display[1] = IMD_ON + display[2] = 2 + display[3] = IMD_EOD + display[4] = IMD_GREEN + display[5] = IMD_EOD + display[6] = IMD_EOD # all quads + call gescape ( gp, IMD_DISPLAY_I, display, 6) + + # now set up grey scale changing upward in frame 1 + set_image[1] = 1 + set_image[2] = IMD_EOD + set_image[3] = IMD_EOD # all planes + call gescape ( gp, IMD_SET_IP, set_image, 3) + for ( i = 1; i <= DIM ; i = i + 1 ) { + call amovks ( i-1, data, DIM) + y = real(i-1)/(DIM-1) + call gpcell ( gp, data, DIM, 1, 0., y, 1., y) + } + + # grey scale changing horizontally in frame 2 + set_image[1] = 2 + call gescape ( gp, IMD_SET_IP, set_image, 3) + do i = 1, DIM + data[i] = i + call gpcell ( gp, data, DIM, 1, 0., 0., 1., 1.) + + # set the cursor + call gscur ( gp, 0.0, 1.0) + + # read cursor + # call ggcur( gp, sx, sy, key) + + # all done + call gclose ( gp ) + call close ( fd ) +end diff --git a/pkg/images/tv/iis/ids/testcode/grin.x b/pkg/images/tv/iis/ids/testcode/grin.x new file mode 100644 index 00000000..b76e58b2 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/grin.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "ids.h" + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# create a grey scale test image, using frames 1 and 2, and +# position the cursor in the upper right quadrant. + +procedure t_im() + +pointer gp +char device[SZ_FNAME] + +pointer gopen() +int open() +int dd[LEN_GKIDD] + +short i,data[DIM+1] +short display[6] +short set_image[3] +real y, sx, sy +int key + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream(STDIMAGE) + + data[1] = IDS_R_HARD + call gescape ( gp, IDS_RESET, data, 1) + # display all frames off + display[1] = IDS_OFF + display[2] = IDS_EOD # all frames + display[3] = IDS_EOD # all colors + display[4] = IDS_EOD # all quads + call gescape ( gp, IDS_DISPLAY_I, display, 6) + # display frames 1, 2 on -- 1 red, 2 green + display[1] = IDS_ON + display[2] = 1 + display[3] = IDS_EOD + display[4] = IDS_RED + display[5] = IDS_EOD + display[6] = IDS_EOD # all quads + call gescape ( gp, IDS_DISPLAY_I, display, 6) + display[1] = IDS_ON + display[2] = 2 + display[3] = IDS_EOD + display[4] = IDS_GREEN + display[5] = IDS_EOD + display[6] = IDS_EOD # all quads + call gescape ( gp, IDS_DISPLAY_I, display, 6) + + # now set up grey scale changing upward in frame 1 + set_image[1] = 1 + set_image[2] = IDS_EOD + set_image[3] = IDS_EOD # all planes + call gescape ( gp, IDS_SET_IP, set_image, 3) + for ( i = 1; i <= DIM ; i = i + 1 ) { + call amovks ( i-1, data, DIM) + y = real(i-1)/(DIM-1) + call gpcell ( gp, data, DIM, 1, 0., y, 1., y) + } + + # grey scale changing horizontally in frame 2 + set_image[1] = 2 + call gescape ( gp, IDS_SET_IP, set_image, 3) + do i = 1, DIM + data[i] = i-1 + call gpcell ( gp, data, DIM, 1, 0., 0., 1., 1.) + + # set the cursor + call gscur ( gp, 0.0, 1.0) + + # read cursor + call ggcur (gp, sx, sy, key) + call eprintf("cursor read as : (%f,%f) (%d,%d), key %d\n") + call pargr (sx) + call pargr (sy) + call pargi ( int(sx*32767)/64) + call pargi ( int(sy*32767)/64) + call pargi (key) + + # all done + call gclose (gp) + call ids_close +end diff --git a/pkg/images/tv/iis/ids/testcode/scr.x b/pkg/images/tv/iis/ids/testcode/scr.x new file mode 100644 index 00000000..ec4821cf --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/scr.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# scroll + +procedure t_im() + +pointer gp +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int fd + +pointer gopen() +bool streq() +int open() +common /local/gp + +begin + call clgstr("output", output, SZ_FNAME) + if (!streq (output, "") ) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$stdimage", NEW_FILE, BINARY_FILE) + + call clgstr("device", device, SZ_FNAME) + gp = gopen ( device, NEW_FILE, fd) + + call cl_button + call scroll(0,0) + call cursor(128,128) + call wt_button + call scroll(128,195) + call cursor(128,128) + call wt_button + call zm(4,128,128) + call wt_button + call cursor(128,128) + call wt_button + call zm(1,205,205) + + # all done + call gclose ( gp ) + call close ( fd ) +end + +procedure scroll(x,y) + +int x,y + +pointer gp +common /local/gp +short data[8] + +begin + data[1] = IMD_SCROLL + data[2] = IMD_WRITE + data[3] = 2 + data[4] = IMD_EOD + data[5] = IMD_EOD + data[6] = 0 + data[7] = (x-1) * MCXSCALE + data[8] = (y-1) * MCYSCALE + call gescape(gp, IMD_CONTROL, data, 8) +end + +procedure cursor(x,y) + +int x,y +pointer gp +real xr, yr +common /local/gp + +begin + xr = real((x-1)*MCXSCALE)/GKI_MAXNDC + yr = real((y-1)*MCXSCALE)/GKI_MAXNDC + call gseti(gp, G_CURSOR, 1) + call gscur(gp, xr, yr) +end + +procedure wt_button + +real x,y +int key +pointer gp +common /local/gp +begin + call gseti(gp, G_CURSOR, IMD_BUT_WT) + call ggcur(gp, x, y, key) +end + +procedure cl_button + +real x,y +int key +pointer gp +common /local/gp + +begin + call gseti(gp, G_CURSOR, IMD_BUT_RD) + call ggcur(gp, x, y, key) +end + +procedure zm(power, x,y) + +int power +int x,y + +short data[9] +pointer gp +common /local/gp + +begin + data[1] = IMD_ZOOM + data[2] = IMD_WRITE + data[3] = 3 + data[4] = IMD_EOD + data[5] = IMD_EOD + data[6] = 0 + data[7] = power + data[8] = (x-1) * MCXSCALE + data[9] = (y-1) * MCYSCALE + call gescape(gp, IMD_CONTROL, data, 9) +end diff --git a/pkg/images/tv/iis/ids/testcode/scrin.x b/pkg/images/tv/iis/ids/testcode/scrin.x new file mode 100644 index 00000000..7a704fe4 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/scrin.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ids.h" +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# scroll + +procedure t_im() + +pointer gp +char device[SZ_FNAME] + +pointer gopen() +int dd[LEN_GKIDD] +common /local/gp + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + call cl_button + call scroll(1,1) + call cursor(129,129) + call wt_button + call scroll(129,195) + call cursor(129,129) + call wt_button + call zm(4,129,129) + call wt_button + call cursor(129,129) + call wt_button + call zm(1,205,205) + + # all done + call gclose ( gp ) + call ids_close +end + +procedure scroll(x,y) + +int x,y + +pointer gp +common /local/gp +short data[8] + +begin + data[1] = IDS_SCROLL + data[2] = IDS_WRITE + data[3] = 2 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = (x-1) * MCXSCALE + data[8] = (y-1) * MCYSCALE + call gescape(gp, IDS_CONTROL, data, 8) +end + +procedure cursor(x,y) + +int x,y +pointer gp +real xr, yr +common /local/gp + +begin + xr = real((x-1)*MCXSCALE)/GKI_MAXNDC + yr = real((y-1)*MCXSCALE)/GKI_MAXNDC + call gseti(gp, G_CURSOR, 1) + call gscur(gp, xr, yr) +end + +procedure wt_button + +real x,y +int key +pointer gp +common /local/gp +begin + call gseti(gp, G_CURSOR, IDS_BUT_WT) + call ggcur(gp, x, y, key) +end + +procedure cl_button + +real x,y +int key +pointer gp +common /local/gp + +begin + call gseti(gp, G_CURSOR, IDS_BUT_RD) + call ggcur(gp, x, y, key) +end + +procedure zm(power, x,y) + +int power +int x,y + +short data[9] +pointer gp +common /local/gp + +begin + data[1] = IDS_ZOOM + data[2] = IDS_WRITE + data[3] = 3 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = power + data[8] = (x-1) * MCXSCALE + data[9] = (y-1) * MCYSCALE + call gescape(gp, IDS_CONTROL, data, 9) +end diff --git a/pkg/images/tv/iis/ids/testcode/sn.x b/pkg/images/tv/iis/ids/testcode/sn.x new file mode 100644 index 00000000..ebce47c0 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/sn.x @@ -0,0 +1,192 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ids.h" +include +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# snap + +procedure t_im() + +pointer gp +char device[SZ_FNAME] +char cjunk[SZ_FNAME] + +pointer gopen() +int dd[LEN_GKIDD] + +int key, fnum, zfac +int ps, pe +real x, y +real xjunk, yjunk +int clgeti +bool image, clgetb + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + # read first to clear box + call gseti(gp, G_CURSOR, IDS_BUT_RD) + call ggcur(gp, xjunk, yjunk, key) + + repeat { + if (clgetb ("done?")) + break + + zfac = clgeti ("zoom factor") + + call clgstr ("Set zoom center, press ", cjunk, SZ_FNAME) + call gseti (gp, G_CURSOR, 1) + call ggcur(gp, x, y, key) + call zm(gp, zfac, x, y) + + image = clgetb("Do you want a picture?") + if (image) + call snapi (gp) + else { + repeat { + ps = clgeti ("starting line") + if ( ps == -1) + break + pe = clgeti ("ending line") + call snap (gp, ps, pe) + } + } + } + + + # all done + call gclose ( gp ) + call ids_close +end + +# zoom + +procedure zm(gp, pow, x, y) + +int pow +pointer gp +real x, y + +short data[9] + +begin + data[1] = IDS_ZOOM + data[2] = IDS_WRITE + data[3] = 3 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = 2**(pow-1) + data[8] = x * GKI_MAXNDC + data[9] = y * GKI_MAXNDC + call gescape ( gp, IDS_CONTROL, data[1], 9) +end + +procedure snap (gp, ps, pe) + +pointer gp +int ps, pe + +real y +short data[7] +pointer sp +pointer sndata +int i,j + +begin + call smark (sp) + data[1] = IDS_SNAP + data[2] = IDS_WRITE + data[3] = 1 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = IDS_SNAP_RGB + call gescape (gp, IDS_CONTROL, data, 7) + + if (pe < ps) { + call eprintf("Can't handle ending position < start \n") + return + } + + call salloc ( sndata, DIM, TY_SHORT) + call eprintf ("snapping from %d through %d\n") + call pargi (ps) + call pargi (pe) + call eprintf ("data values 0-5 255 256 511\n") + do i = ps, pe { + y = real(i)*MCYSCALE / GKI_MAXNDC. + call ggcell (gp, Mems[sndata], DIM, 1, 0.0, y, 1.0, y) + call eprintf ("r%3d data:") + call pargi (i) + call eprintf (" %5d %5d %5d %5d %5d %5d %5d %5d %5d\n") + do j = 0, 5 + call pargs (Mems[sndata+j]) + call pargs (Mems[sndata+255]) + call pargs (Mems[sndata+256]) + call pargs (Mems[sndata+511]) + } + + data[1] = IDS_R_SNAPDONE + call gescape (gp, IDS_RESET, data, 1) + + call sfree (sp) +end + +procedure snapi (gp) + +pointer gp + +real y +short data[7] +pointer im, immap(), impl2s() +char fname[SZ_FNAME] +int i + +begin + call clgstr ("file", fname, SZ_FNAME) + im = immap(fname, NEW_FILE, 0) + IM_PIXTYPE(im) = TY_SHORT + IM_LEN(im,1) = DIM + IM_LEN(im,2) = DIM + + data[1] = IDS_SNAP + data[2] = IDS_WRITE + data[3] = 1 + data[4] = IDS_EOD + data[5] = IDS_EOD + data[6] = 0 + data[7] = IDS_SNAP_RGB + call gescape (gp, IDS_CONTROL, data, 7) + + do i = 0, 511 { + if ( mod(i,52) == 0) { + call eprintf ("%d ") + call pargi (100*i/DIM) + call flush (STDERR) + } + y = real(i)*MCYSCALE / GKI_MAXNDC. + call ggcell (gp, Mems[impl2s(im,i+1)], 512, 1, 0.0, y, 1.0, y) + } + call eprintf ("\n") + + call imunmap(im) + data[1] = IDS_R_SNAPDONE + call gescape (gp, IDS_RESET, data, 1) +end diff --git a/pkg/images/tv/iis/ids/testcode/t_giis.x b/pkg/images/tv/iis/ids/testcode/t_giis.x new file mode 100644 index 00000000..601bc17b --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/t_giis.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# GIIS -- Graphics kernel for image output to the IIS. +# The whole package is copied as much as possible from the stdgraph package. + +procedure t_giis() + +int fd, list +pointer gki, sp, fname, devname +int dev[LEN_GKIDD], deb[LEN_GKIDD] +int debug, verbose, gkiunits +bool clgetb() +int clpopni(), clgfil(), open(), btoi() +int gki_fetch_next_instruction() + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Open list of metafiles to be decoded. + list = clpopni ("input") + + # Get parameters. + call clgstr ("device", Memc[devname], SZ_FNAME) + if (clgetb ("generic")) { + debug = NO + verbose = NO + gkiunits = NO + } else { + debug = btoi (clgetb ("debug")) + verbose = btoi (clgetb ("verbose")) + gkiunits = btoi (clgetb ("gkiunits")) + } + + # Open the graphics kernel. + call ids_open (Memc[devname], dev) + call gkp_install (deb, STDERR, verbose, gkiunits) + + # Process a list of metacode files, writing the decoded metacode + # instructions on the standard output. + + while (clgfil (list, Memc[fname], SZ_FNAME) != EOF) { + # Open input file. + iferr (fd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + call erract (EA_WARN) + next + } + + # Process the metacode instruction stream. + while (gki_fetch_next_instruction (fd, gki) != EOF) { + if (debug == YES) + call gki_execute (Mems[gki], deb) + call gki_execute (Mems[gki], dev) + } + + call close (fd) + } + + call gkp_close() + call ids_close() + call clpcls (list) + call sfree (sp) +end diff --git a/pkg/images/tv/iis/ids/testcode/zm.x b/pkg/images/tv/iis/ids/testcode/zm.x new file mode 100644 index 00000000..dff01cbe --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/zm.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imd.h" +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# zoom + +procedure t_im() + +pointer gp +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int fd + +pointer gopen() +bool streq() +int open() + +short i,data[DIM+1] +short set_image[6] +int key +real x[30],y[30] +int xjunk, yjunk + +begin + call clgstr("output", output, SZ_FNAME) + if (!streq (output, "") ) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$stdimage", NEW_FILE, BINARY_FILE) + + call clgstr("device", device, SZ_FNAME) + gp = gopen ( device, NEW_FILE, fd) + + # now zoom after reading button presses + # read first to clear box + call gseti(gp, G_CURSOR, IMD_BUT_RD) + call ggcur(gp, xjunk, yjunk, key) + + for ( i = 1 ; i < 5 ; i = i + 1) { + call gseti(gp, G_CURSOR, IMD_BUT_WT) + call ggcur(gp, xjunk, yjunk, key) + + data[11] = IMD_ZOOM + data[12] = IMD_WRITE + data[13] = 3 + data[14] = IMD_EOD + data[15] = IMD_EOD + data[16] = 0 + data[17] = 4 + data[18] = (((i-1)* 128)-1) * MCXSCALE + data[19] = (((i-1)* 128)-1) * MCYSCALE + call gescape ( gp, IMD_CONTROL, data[11], 9) + } + + # all done + call gclose ( gp ) + call close ( fd ) +end diff --git a/pkg/images/tv/iis/ids/testcode/zmin.x b/pkg/images/tv/iis/ids/testcode/zmin.x new file mode 100644 index 00000000..676a72f0 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/zmin.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "ids.h" +include +include + +define DIM 512 +define MCXSCALE 64 +define MCYSCALE 64 + +# zoom + +procedure t_im() + +pointer gp +char device[SZ_FNAME] + +pointer gopen() +int dd[LEN_GKIDD] + +short i,data[DIM+1] +short set_image[6] +int key +real x[30],y[30] +real xjunk, yjunk + +begin + call clgstr("device", device, SZ_FNAME) + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, NEW_FILE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + # now zoom after reading button presses + # read first to clear box + call gseti(gp, G_CURSOR, IDS_BUT_RD) + call ggcur(gp, xjunk, yjunk, key) + + for ( i = 1 ; i < 5 ; i = i + 1) { + call gseti (gp, G_CURSOR, IDS_BUT_WT) + call ggcur(gp, xjunk, yjunk, key) + call gseti (gp, G_CURSOR, 1) + call rpc(gp, xjunk, yjunk, key) + + data[11] = IDS_ZOOM + data[12] = IDS_WRITE + data[13] = 3 + data[14] = IDS_EOD + data[15] = IDS_EOD + data[16] = 0 + data[17] = 4 + data[18] = min(((i-1)* 128) * MCXSCALE, GKI_MAXNDC) + data[19] = min(((i-1)* 128) * MCYSCALE, GKI_MAXNDC) + call gescape ( gp, IDS_CONTROL, data[11], 9) + } + + # all done + call gclose ( gp ) + call ids_close +end + +# rpcursor --- read and print cursor + +procedure rpc(gp, sx, sy, key) + +pointer gp +real sx,sy +int key + +begin + call ggcur (gp, sx, sy, key) + call eprintf("cursor: (%f,%f) (%d,%d) key %d\n") + call pargr (sx) + call pargr (sy) + call pargi ( int(sx*32767)/64) + call pargi ( int(sy*32767)/64) + call pargi (key) +end diff --git a/pkg/images/tv/iis/ids/testcode/zztest.x b/pkg/images/tv/iis/ids/testcode/zztest.x new file mode 100644 index 00000000..599b7103 --- /dev/null +++ b/pkg/images/tv/iis/ids/testcode/zztest.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +define XS 0.216 +define XE 0.719 +define YS 0.214 +define YE 0.929 + +task test = t_test + +# T_TEST -- Test program for graphics plotting. A labelled grid is output. + +procedure t_test () + +bool redir +pointer sp, gp +char command[SZ_LINE], image[SZ_FNAME], word[SZ_LINE] +char output[SZ_FNAME], output_file[SZ_FNAME], device[SZ_FNAME] +int cmd, input_fd, stat, fd + +pointer gopen() +bool streq() +int fstati(), open(), getline() + +begin + # If the input has been redirected, input is read from the named + # command file. If not, each image name in the input template is + # plotted. + + if (fstati (STDIN, F_REDIR) == YES) { +call eprintf ("Input has been redirected\n") + redir = true + cmd = open (STDIN, READ_ONLY, TEXT_FILE) + } + + # Loop over commands until EOF + repeat { + if (redir) { + if (getline (STDIN, command, SZ_LINE) == EOF) + break + call sscan (command) + call gargwrd (word, SZ_LINE) + if (!streq (word, "plot")) { + # Pixel window has been stored as WCS 2 + call gseti (gp, G_WCS, 2) + call gscan (command) + next + } else + call gargwrd (image) + } + + call clgstr ("output", output, SZ_FNAME) + if (!streq (output, "")) { + call strcpy (output, output_file, SZ_FNAME) + fd = open (output_file, NEW_FILE, BINARY_FILE) + } else + fd = open ("dev$crt", NEW_FILE, BINARY_FILE) + + call clgstr ("device", device, SZ_FNAME) + gp = gopen (device, NEW_FILE, fd) + + call gseti (gp, G_XDRAWGRID, 1) + call gseti (gp, G_YDRAWGRID, 1) + call gseti (gp, G_NMAJOR, 21) + call glabax (gp, "TEST", "NDC_X", "NDC_Y") + call gline (gp, XS, YS, XE, YS) + call gline (gp, XE, YS, XE, YE) + call gline (gp, XE, YE, XS, YE) + call gline (gp, XS, YE, XS, YS) + call gmark (gp, 0.5, 0.5, GM_CROSS, 3.0, 3.0) + call gtext (gp, XS, YS-0.1, "DICOMED crtpict film area") + call gclose (gp) + call close (fd) + } + + call clpcls (input_fd) + call sfree (sp) +end diff --git a/pkg/images/tv/iis/iis.cl b/pkg/images/tv/iis/iis.cl new file mode 100644 index 00000000..becb72c4 --- /dev/null +++ b/pkg/images/tv/iis/iis.cl @@ -0,0 +1,22 @@ +plot + +#{ IIS -- The IIS Image Display Control package. + +package iis + +set iis = "images$tv/iis/" + +task cv, + cvl = "iis$x_iis.e" + +task blink = "iis$blink.cl" +task erase = "iis$erase.cl" +task $frame = "iis$frame.cl" +task lumatch = "iis$lumatch.cl" +task $monochrome = "iis$monochrome.cl" +task pseudocolor = "iis$pseudocolor.cl" +task rgb = "iis$rgb.cl" +task $window = "iis$window.cl" +task zoom = "iis$zoom.cl" + +clbye() diff --git a/pkg/images/tv/iis/iis.hd b/pkg/images/tv/iis/iis.hd new file mode 100644 index 00000000..a0be19f2 --- /dev/null +++ b/pkg/images/tv/iis/iis.hd @@ -0,0 +1,16 @@ +# Help directory for the IIS package + +$doc = "images$tv/iis/doc/" +$iis = "images$tv/iis/" + +blink hlp=doc$blink.hlp, src=iis$blink.cl +cv hlp=doc$cv.hlp src=iis$src/cv.x +cvl hlp=doc$cvl.hlp +erase hlp=doc$erase.hlp, src=iis$erase.cl +frame hlp=doc$frame.hlp, src=iis$frame.cl +lumatch hlp=doc$lumatch.hlp, src=iis$lumatch.cl +monochrome hlp=doc$monochrome.hlp, src=iis$monochrome.cl +pseudocolor hlp=doc$pseudocolor.hlp, src=iis$pseudocolor.cl +rgb hlp=doc$rgb.hlp, src=iis$rgb.cl +window hlp=doc$window.hlp, src=iis$window.cl +zoom hlp=doc$zoom.hlp, src=iis$zoom.cl diff --git a/pkg/images/tv/iis/iis.men b/pkg/images/tv/iis/iis.men new file mode 100644 index 00000000..08123e61 --- /dev/null +++ b/pkg/images/tv/iis/iis.men @@ -0,0 +1,11 @@ + blink - Blink two frames + cv - Control image device, display "snapshot" + cvl - Load image display (newer version of 'display') + erase - Erase an image frame + frame - Select the frame to be displayed + lumatch - Match the lookup tables of two frames + monochrome - Select monochrome enhancement + pseudocolor - Select pseudocolor enhancement + rgb - Select true color mode (red, green, and blue frames) + window - Adjust the contrast and dc offset of the current frame + zoom - Zoom in on the image (change magnification) diff --git a/pkg/images/tv/iis/iis.par b/pkg/images/tv/iis/iis.par new file mode 100644 index 00000000..db706f09 --- /dev/null +++ b/pkg/images/tv/iis/iis.par @@ -0,0 +1 @@ +version,s,h,"Apr91" diff --git a/pkg/images/tv/iis/iism70/README b/pkg/images/tv/iis/iism70/README new file mode 100644 index 00000000..05f01307 --- /dev/null +++ b/pkg/images/tv/iis/iism70/README @@ -0,0 +1,5 @@ +IISM70 -- Device dependent interface subroutines for the IIS Model 70 image +display device. This package uses the ZFIOGD device driver, which is +responsible for physical i/o to the device. The source for the ZFIOGD driver +is in host$gdev; this driver must be compiled and installed in a system library +(libsys.a) before i/o to the IIS will work correctly. diff --git a/pkg/images/tv/iis/iism70/idsexpand.x b/pkg/images/tv/iis/iism70/idsexpand.x new file mode 100644 index 00000000..da2a172d --- /dev/null +++ b/pkg/images/tv/iis/iism70/idsexpand.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# IDS_EXPAND -- expand FRAME/BITPL if first element is IDS_EOD +# if the frames are not counted in order, as on the Model 75, +# that should be dealt with here (use the "flag" boolean). + +procedure ids_expand(data, max, flag) + +short data[ARB] # data +short max # max number of frames/bitplanes +bool flag # true if frames ... e.g. for Model 75 + +int i + +begin + if ( data[1] != IDS_EOD ) + return + do i = 1, max { + data[i] = i + } + if ( flag) { + data[1+max] = GRCHNUM + data[2+max] = IDS_EOD + } else + data[1+max] = IDS_EOD +end diff --git a/pkg/images/tv/iis/iism70/iis.com b/pkg/images/tv/iis/iism70/iis.com new file mode 100644 index 00000000..25a69d38 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iis.com @@ -0,0 +1,12 @@ +# Common for IIS display + +int iischan # The device channel used by FIO +int iisnopen # Number of times the display has been opened +int iframe, iplane # frame, bitplanes to read/write +int i_frame_on # Which frame is on...cursor readback +short hdr[LEN_IISHDR] # Header +short zoom[16] # zoom for each plane +short xscroll[16] # scroll position for each plane +short yscroll[16] +common /iiscom/iischan, iisnopen, iframe, iplane, i_frame_on, + hdr, zoom, xscroll, yscroll diff --git a/pkg/images/tv/iis/iism70/iis.h b/pkg/images/tv/iis/iism70/iis.h new file mode 100644 index 00000000..96bb8b39 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iis.h @@ -0,0 +1,120 @@ +# This file contains the hardware definitions for the iis model 70/f +# at Kitt Peak. + +# Define header +define LEN_IISHDR 8 # Length of IIS header + +define XFERID $1[1] # transfer id +define THINGCT $1[2] # thing count +define SUBUNIT $1[3] # subuint select +define CHECKSUM $1[4] # check sum +define XREG $1[5] # x register +define YREG $1[6] # y register +define ZREG $1[7] # z register +define TREG $1[8] # t register + +# Transfer ID definitions +define IREAD 100000B +define IWRITE 0B +define PACKED 40000B +define BYPASSIFM 20000B +define BYTE 10000B +define ADDWRITE 4000B +define ACCUM 2000B +define BLOCKXFER 1000B +define VRETRACE 400B +define MUX32 200B + +# Subunits +define REFRESH 1 +define LUT 2 +define OFM 3 +define IFM 4 +define FEEDBACK 5 +define SCROLL 6 +define VIDEOM 7 +define SUMPROC 8 +define GRAPHICS 9 +define CURSOR 10 +define ALU 11 +define ZOOM 12 +define IPB 15 + +# Command definitions +define COMMAND 100000B +define ADVXONTC 100000B # Advance x on thing count +define ADVXONYOV 40000B # Advance x on y overflow +define ADVYONXOV 100000B # Advance y on x overflow +define ADVYONTC 40000B # Advance y on thing count +define ERASE 100000B # Erase + +# 4 - Button Trackball +define PUSH 40000B +define BUTTONA 400B +define BUTTONB 1000B +define BUTTONC 2000B +define BUTTOND 4000B + +# Display channels +define CHAN1 1B +define CHAN2 2B +define CHAN3 4B +define CHAN4 10B +define ALLCHAN 17B +define GRCHAN 100000B +define GRCHNUM 16 + +define LEN_IISFRAMES 4 +define IISFRAMES CHAN1, CHAN2, CHAN3, CHAN4 + +# Center coordinates for zoom/scroll +define IIS_XCEN 256 +define IIS_YCEN 255 +# Inverted Y center is just IIS_YDIM - IIS_YCEN +define IIS_YCEN_INV 256 + +# Colors + +# these are bit plane mappings +define BLUE 1B +define GREEN 2B +define RED 4B +define MONO 7B +# next colors used by snap code ... used as array indexes. +define BLU 1 +define GR 2 +define RD 3 + + +# Bit plane selections +define BITPL0 1B +define BITPL1 2B +define BITPL2 4B +define BITPL3 10B +define BITPL4 20B +define BITPL5 40B +define BITPL6 100B +define BITPL7 200B +define ALLBITPL 377B + +# IIS Sizes +define IIS_XDIM 512 +define IIS_YDIM 512 +define MCXSCALE 64 # Metacode x scale +define MCYSCALE 64 # Metacode y scale +define SZB_IISHDR 16 # Size of IIS header in bytes +define LEN_ZOOM 3 # Zoom parameters +define LEN_CURSOR 3 # Cursor parameters +define LEN_SELECT 12 # frame select +define LEN_LUT 256 # Look up table +define LEN_OFM 1024 # Output function look up table +define LEN_IFM 8192 # Input function look up table +define LEN_VIDEOM 2048 # videometer output memory +define LEN_GRAM 256 # graphics ram +define MAXX 512 # maximum x register + 1 + +# IIS Status Words +define IIS_FILSIZE (IIS_XDIM * IIS_YDIM * SZB_CHAR) +define IIS_BLKSIZE 1 +define IIS_OPTBUFSIZE 32768 +define IIS_MAXBUFSIZE 32768 diff --git a/pkg/images/tv/iis/iism70/iisbutton.x b/pkg/images/tv/iis/iism70/iisbutton.x new file mode 100644 index 00000000..50dfff7b --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisbutton.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# IISBUTTON -- Read, button status + +procedure iisbutton (cnum, x, y, key) + +int cnum # cursor number +int x,y # coordinates +int key # key pressed + +short status +int and() + +include "iis.com" + +begin + call iishdr (IREAD, 1, CURSOR+COMMAND, 0, 0, 0, 0) + call iisio (status, 1 * SZB_CHAR) + + if ( cnum == IDS_BUT_WT ) { + while ( and (int(status), PUSH) == 0 ) { + call tsleep(1) + call iisio (status, 1 * SZB_CHAR) + } + } + + if ( and ( int(status), PUSH) == 0 ) + key = 0 + else { + status = and ( int(status), 7400B) / 256 + switch(status) { + case 4: + status = 3 + + case 8: + status = 4 + } + key = status + } +end diff --git a/pkg/images/tv/iis/iism70/iiscls.x b/pkg/images/tv/iis/iism70/iiscls.x new file mode 100644 index 00000000..c717f636 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iiscls.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +define LEN_HID 5 + +# IISCLS -- Close IIS display. + +procedure iiscls (chan, status) + +int chan[ARB] +int status + +include "iis.com" + +begin + # first we need to tuck away the constants for zoom and scroll + # as we cannot read them on the model 70. Would that there were + # somewhere to put them. Alas not. So just drop them on the floor. + + if (iisnopen == 1) { + call zclsgd (iischan, status) + iisnopen = 0 + } +end diff --git a/pkg/images/tv/iis/iism70/iiscursor.x b/pkg/images/tv/iis/iism70/iiscursor.x new file mode 100644 index 00000000..5ffc9131 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iiscursor.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# cscale makes 0-32767 range from 0-62. The 62 results from the need +# to describe a cursor with a center, and hence an ODD number of points. +# Thus, we pretend the cursor ranges from 0-62 rather than 0-63, and +# the center is at (31,31). +# cwidth describes the (cursor) ram width, which is 64 ( by 64). + +define CSCALE 528 +define CWIDTH 64 +define CSIZE 4096 + +# IISCURSOR -- Read, Write cursor shape, turn cursor on/off + +procedure iiscursor (rw, cur, n, data) + +short rw # read or write +short cur # cursor number ... ignored for IIS M70 +short n # number of data values +short data[ARB] # the data + +short command, len +short shape[CSIZE] +short status +int rate +int i,j,index +int mod(), and(), or(), andi() + +include "iis.com" + +begin + len = 1 + if (data[1] != IDS_CSHAPE) { + call iishdr (IREAD, len, CURSOR+COMMAND, 0, 0, 0, 0) + call iisio (status, len * SZB_CHAR) + } + + if (rw == IDS_WRITE) + command = andi (IWRITE+VRETRACE, 177777B) + else + command = andi (IREAD+VRETRACE, 177777B) + + if (data[1] != IDS_CSHAPE){ + if (rw == IDS_WRITE) { + switch (data[1]) { + case IDS_OFF: + status = and(int(status), 177776B) + + case IDS_ON: + status = or (int(status), 1) + + case IDS_CBLINK: + rate = mod (int(data[2])-1, 4) * 8 + status = or (rate, and (int(status),177747B)) + } + call iishdr (command, len, CURSOR+COMMAND, 0, 0, 0, 0) + call iisio (status, len * SZB_CHAR) + } else { + if ( data[1] == IDS_CBLINK ) + data[2] = ( and (int(status), 30B) / 8 ) + 1 + else if ( and ( int(status), 1) == 0 ) + data[1] = IDS_OFF + else + data[1] = IDS_ON + } + + } else { + # deal with cursor shape. + + len = CSIZE + if ( rw == IDS_WRITE) { + call aclrs (shape, CSIZE) + for ( i = 2 ; i <= n-1 ; i = i + 2 ) { + # given GKI data pairs for x,y cursor_on bits, set shape datum + # the first value is x, then y + if (data[i] == IDS_EOD) + break + j = data[i]/CSCALE + index = (data[i+1]/CSCALE) * CWIDTH + j + 1 + shape[index] = 1 + } + } + + call iishdr (command, len, CURSOR, ADVXONTC, ADVYONXOV, 0, 0) + call iisio (shape, len * SZB_CHAR) + + # if read command, return all set bits as GKI x,y pairs + if ( rw != IDS_WRITE) { + i = 2 + for ( j = 1 ; j <= CSIZE ; j = j + 1 ) { + if ( shape[j] != 0 ) { + data[i] = mod(j,CWIDTH) * CSCALE + data[i+1] = (j/CWIDTH) * CSCALE + i = i + 2 + if ( i > n-1 ) + break + } + } + if ( i <= n ) + data[i] = IDS_EOD + n = i + } + } +end diff --git a/pkg/images/tv/iis/iism70/iishdr.x b/pkg/images/tv/iis/iism70/iishdr.x new file mode 100644 index 00000000..bf22d493 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iishdr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# IISHDR -- Form IIS header. + +procedure iishdr (id, count, subunit, x, y, z, t) + +int id, count, subunit, x, y, z, t +int i, sum +include "iis.com" + +begin + XFERID(hdr) = id + THINGCT(hdr) = count + SUBUNIT(hdr) = subunit + XREG(hdr) = x + YREG(hdr) = y + ZREG(hdr) = z + TREG(hdr) = t + CHECKSUM(hdr) = 1 + + if (THINGCT(hdr) > 0) + THINGCT(hdr) = -THINGCT(hdr) + + sum = 0 + for (i = 1; i <= LEN_IISHDR; i = i + 1) + sum = sum + hdr[i] + CHECKSUM(hdr) = -sum +end diff --git a/pkg/images/tv/iis/iism70/iishisto.x b/pkg/images/tv/iis/iism70/iishisto.x new file mode 100644 index 00000000..374342a0 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iishisto.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# IISHISTO -- Activate, Read histogram. + +procedure iishisto (rw, color, offset, a_n, data) + +short rw # read or write +short color[ARB] # color(s) to write +short offset # offset into histogram table +short a_n # number of data values +short data[ARB] # the data + +int n, command, off, len, x, y, z +include "iis.com" + +begin + n = a_n + if (n < 1) + return + + # set the area to be histogrammed ... in data[1], currently + # device very specific ( 2 == whole region) . Need to fix this + # perhaps via specific graph plane filled with gkifill command to + # depict area desired. + # n must be twice the number of datum values. Upper level code + # must know this to leave enough room. Would be better if upper + # code could ignore this (fact). + + if (rw == IDS_WRITE) { + command = IWRITE+VRETRACE + x = 0 + y = 0 + z = 0 + len = 1 + data[1] = 2 + call iishdr (command, len, VIDEOM+COMMAND, x, y, z, 0) + call iisio (data[1], len * SZB_CHAR) + return + } + + off = offset + command = IREAD+VRETRACE + len = min (n, LEN_VIDEOM-off+1) + off = min (LEN_VIDEOM, off) - 1 + y = off/MAXX + ADVYONXOV + x = mod (off, MAXX) + ADVXONTC + call iishdr (command, len, VIDEOM, x, y, z, 0) + call iisio (data, len * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/iisifm.x b/pkg/images/tv/iis/iism70/iisifm.x new file mode 100644 index 00000000..ef04a1be --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisifm.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LUT_IMAX 255 + +# IISIFM -- Read and Write INPUT look up table. +# Written data is from line end points, read data +# is full array. + +procedure iisifm (rw, offset, n, data) + +short rw # read or write +short offset # offset into lut +short n # number of data values +short data[ARB] # the data + +int command,len,x,y +pointer sp, idata + +include "iis.com" + +begin + if ( rw == IDS_WRITE) { + if (n < 4) + return + + call smark (sp) + call salloc (idata, LEN_IFM, TY_SHORT) + call aclrs (Mems[idata], LEN_IFM) + + command = IWRITE+VRETRACE + call idslfill (data, int(n), Mems[idata], LEN_IFM, 0, LUT_IMAX) + len = LEN_IFM + } else { + len = n + command = IREAD+VRETRACE + } + + y = ADVYONXOV + x = ADVXONTC + call iishdr (command, len, IFM, x, y, 0, 0) + + if (rw == IDS_WRITE) { + call iisio (Mems[idata], len * SZB_CHAR) + call sfree (sp) + } else + call iisio (data, len * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/iisio.x b/pkg/images/tv/iis/iism70/iisio.x new file mode 100644 index 00000000..f8e005c6 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisio.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# IISIO -- Read/Write to IIS. + +procedure iisio (buf, nbytes) + +short buf[ARB] +int nbytes + +int nbites +int and() + +include "iis.com" + +begin + call iiswt (iischan, nbites) + if (nbites == ERR) + return + + call zawrgd (iischan, hdr, SZB_IISHDR, 0) + call iiswt (iischan, nbites) + if (nbites == ERR) + return + + if (and (int(XFERID(hdr)), IREAD) != 0) + call zardgd (iischan, buf, nbytes, 0) + else + call zawrgd (iischan, buf, nbytes, 0) + + call iiswt (iischan, nbites) +end diff --git a/pkg/images/tv/iis/iism70/iislut.x b/pkg/images/tv/iis/iism70/iislut.x new file mode 100644 index 00000000..07819247 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iislut.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LUT_LMAX 255 + +# IISLUT -- Read and Write look up table. +# NOTE the ASYMMETRY ... written data is derived from end +# points, but read data is the full array (see zsnapinit, +# for instance, for read usage.) + +procedure iislut (rw, frame, color, offset, n, data) + +short rw # read or write +short frame[ARB] # frame array +short color[ARB] # color array +short offset # offset into lut +short n # number of data values +short data[ARB] # the data + +int command,len,x,y,z,t +short iispack() +int mapcolor() +pointer sp, ldata + +include "iis.com" + +begin + z = mapcolor (color) + t = iispack(frame) + if (t == GRCHAN) { + return + } + + if ( rw == IDS_WRITE) { + if ( n < 4) + return + command = IWRITE+VRETRACE + + # data space for manipulating lut information + + call smark (sp) + call salloc (ldata, LEN_LUT, TY_SHORT) + call aclrs (Mems[ldata], LEN_LUT) + + # We could have negative lut values, but don't bother for now + call idslfill (data, int(n), Mems[ldata], LEN_LUT, 0, LUT_LMAX) + + len = LEN_LUT + } else { + len = n + command = IREAD+VRETRACE + } + + x = ADVXONTC + y = 0 + + call iishdr (command, len, LUT, x, y, z, t) + + if ( rw == IDS_WRITE) { + call iisio (Mems[ldata], len * SZB_CHAR) + call sfree (sp) + } else + call iisio (data, len * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/iismatch.x b/pkg/images/tv/iis/iism70/iismatch.x new file mode 100644 index 00000000..a2435fdc --- /dev/null +++ b/pkg/images/tv/iis/iism70/iismatch.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# IISMATCH -- copy (match) a set of look up tables to a given table; +# frames/color specify the given table, data gives frame/color for +# set to be changed. + +procedure iismatch (code, frames, color, n, data) + +short code # which table type +short frames[ARB] # reference frame +short color[ARB] # reference color +short n # count of data items +short data[ARB] # frame/color to be changed. + +pointer sp, ldata +int len, x,y,z,t +int unit, i +int mapcolor(), ids_dcopy() +short temp[IDS_MAXIMPL+1] +short iispack() + +include "../lib/ids.com" + +begin + switch (code) { + case IDS_FRAME_LUT: + len = LEN_LUT + x = ADVXONTC + y = 0 + z = mapcolor (color) + t = iispack (frames) + if (t == GRCHAN) + return + unit = LUT + + case IDS_OUTPUT_LUT: + len = LEN_OFM + x = ADVXONTC + y = ADVYONXOV + z = mapcolor (color) + t = 0 + + default: + return + } + + call smark (sp) + call salloc (ldata, len, TY_SHORT) + + call iishdr (IREAD+VRETRACE, len, unit, x, y, z, t) + call iisio (Mems[ldata], len * SZB_CHAR) + + i = ids_dcopy (data, temp) + switch (code) { + case IDS_FRAME_LUT: + call ids_expand (temp, i_maxframes, true) + t = iispack (temp) + i = ids_dcopy (data[i+1], temp) + call ids_expand (temp, 3, false) # 3...max colors + z = mapcolor (temp) + + case IDS_OUTPUT_LUT: + i = ids_dcopy (data[i+1], temp) + call ids_expand (temp, 3, false) + z = mapcolor (temp) + } + + call iishdr (IWRITE+VRETRACE, len, unit, x, y, z, t) + call iisio (Mems[ldata], len * SZB_CHAR) + + call sfree (sp) +end diff --git a/pkg/images/tv/iis/iism70/iisminmax.x b/pkg/images/tv/iis/iism70/iisminmax.x new file mode 100644 index 00000000..22a3062e --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisminmax.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LEN_MM 6 + +# IISMIN -- Read minimum registers + +procedure iismin (rw, color, n, data) + +short rw # read or write +short color[ARB] # color +short n # number of data values +short data[ARB] # the data + +int command,x +short const[LEN_MM] +int i,j + +include "iis.com" + +begin + if ( rw == IDS_WRITE) + return + command = IREAD+VRETRACE + x = ADVXONTC + call iishdr(command, LEN_MM, SUMPROC+COMMAND, x, 0, 0, 0) + call iisio (const, LEN_MM * SZB_CHAR) + j = 1 + for ( i = 1 ; i <= n ; i = i + 1 ) { + switch(color[j]) { + case IDS_RED: + data[i] = const[5] + + case IDS_GREEN: + data[i] = const[3] + + case IDS_BLUE: + data[i] = const[1] + } + j = j+1 + if ( color[j] == IDS_EOD ) + j = j - 1 + } +end + +# IISMAX -- Read maximum registers + +procedure iismax (rw, color, n, data) + +short rw # read or write +short color[ARB] # color +short n # number of data values +short data[ARB] # the data + +int command,x +short const[LEN_MM] +int i,j + +include "iis.com" + +begin + if ( rw == IDS_WRITE) + return + command = IREAD+VRETRACE + x = ADVXONTC + call iishdr(command, LEN_MM, SUMPROC+COMMAND, x, 0, 0, 0) + call iisio (const, LEN_MM * SZB_CHAR) + j = 1 + for ( i = 1 ; i <= n ; i = i + 1 ) { + switch(color[j]) { + case IDS_RED: + data[i] = const[6] + + case IDS_GREEN: + data[i] = const[4] + + case IDS_BLUE: + data[i] = const[2] + } + j = j+1 + if ( color[j] == IDS_EOD ) + j = j - 1 + } +end diff --git a/pkg/images/tv/iis/iism70/iisoffset.x b/pkg/images/tv/iis/iism70/iisoffset.x new file mode 100644 index 00000000..d7f618dc --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisoffset.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LEN_CONST 3 + +# IISOFFSET -- Read and Write output bias registers + +procedure iisoffset (rw, color, n, data) + +short rw # read or write +short color[ARB] # color +short n # number of data values +short data[ARB] # the data + +int command,len,x +short const[3] +int i,j + +include "iis.com" + +begin + command = IREAD+VRETRACE + x = 8 + ADVXONTC + len = LEN_CONST + call iishdr(command, len, SUMPROC+COMMAND, x, 0, 0, 0) + call iisio (const, len * SZB_CHAR) + if ( rw == IDS_WRITE) { + command = IWRITE+VRETRACE + j = 1 + for ( i =1 ; color[i] != IDS_EOD ; i = i + 1) { + switch(color[i]) { + case IDS_RED: + const[3] = data[j] + + case IDS_GREEN: + const[2] = data[j] + + case IDS_BLUE: + const[1] = data[j] + } + if ( j < n) + j = j + 1 + } + call iishdr (command, len, SUMPROC+COMMAND, x, 0, 0, 0) + call iisio (const, len * SZB_CHAR) + } else { + j = 1 + for ( i = 1 ; i <= n ; i = i + 1 ) { + switch(color[j]) { + case IDS_RED: + data[i] = const[3] + + case IDS_GREEN: + data[i] = const[2] + + case IDS_BLUE: + data[i] = const[1] + } + j = j+1 + if ( color[j] == IDS_EOD ) + j = j - 1 + } + } +end diff --git a/pkg/images/tv/iis/iism70/iisofm.x b/pkg/images/tv/iis/iism70/iisofm.x new file mode 100644 index 00000000..0c19c117 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisofm.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LUT_OMAX 1023 + +# IISOFM -- Read and Write OUTPUT look up table. +# Written data is from end points, read data is full +# array. + +procedure iisofm (rw, color, offset, n, data) + +short rw # read or write +short color[ARB] # color(s) to write +short offset # offset into lut +short n # number of data values +short data[ARB] # the data + +int command,len,x,y,z +int mapcolor() +pointer sp, odata + +include "iis.com" + +begin + z = mapcolor (color) + if ( rw == IDS_WRITE) { + if (n < 4) + return + + call smark (sp) + call salloc (odata, LEN_OFM, TY_SHORT) + call aclrs (Mems[odata], LEN_OFM) + + command = IWRITE+VRETRACE + call idslfill (data, int(n), Mems[odata], LEN_OFM, 0, LUT_OMAX) + len = LEN_OFM + } + else { + len = n + command = IREAD+VRETRACE + } + y = ADVYONXOV + x = ADVXONTC + call iishdr (command, len, OFM, x, y, z, 0) + if (rw == IDS_WRITE) { + call iisio (Mems[odata], len * SZB_CHAR) + call sfree (sp) + } else + call iisio (data, len * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/iisopn.x b/pkg/images/tv/iis/iism70/iisopn.x new file mode 100644 index 00000000..29335c62 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisopn.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# IISOPN -- Open IIS display. + +procedure iisopn (devinfo, mode, chan) + +char devinfo[ARB] # device info for zopen +int mode # access mode +int chan[ARB] # receives IIS descriptor + +bool first_time +data first_time /true/ +include "iis.com" + +begin + if (first_time) { + iisnopen = 0 + first_time = false + } + + # We permit multiple opens but only open the physical device once. + if (iisnopen == 0) + call zopngd (devinfo, mode, iischan) + + if (iischan == ERR) + chan[1] = ERR + else { + iisnopen = iisnopen + 1 + chan[1] = iischan + } +end diff --git a/pkg/images/tv/iis/iism70/iispack.x b/pkg/images/tv/iis/iism70/iispack.x new file mode 100644 index 00000000..4c2c70f3 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iispack.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" + +# IISPACK -- Pack color or frame data into a single word. + +short procedure iispack (data) + +short data[ARB] +int value, bit, i +int or() + +begin + value = 0 + for (i=1; data[i] != IDS_EOD; i=i+1) { + bit = data[i] - 1 + value = or (value, 2 ** bit) + } + + return (value) +end diff --git a/pkg/images/tv/iis/iism70/iispio.x b/pkg/images/tv/iis/iism70/iispio.x new file mode 100644 index 00000000..f8c57138 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iispio.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# IISPIO -- Pixel i/o to the IIS. + +procedure iispio (buf, ny) + +short buf[IIS_XDIM,ny] # Cell array +int ny # number of image lines + +pointer iobuf +bool first_time +int xferid, status, npacked, szline, i +int and() +include "iis.com" +data first_time /true/ + +begin + if (first_time) { + call malloc (iobuf, IIS_MAXBUFSIZE, TY_CHAR) + first_time = false + } + + # Wait for the last i/o transfer. + call iiswt (iischan, status) + if (status == ERR) + return + + # Transmit the packet header. + call zawrgd (iischan, hdr, SZB_IISHDR, 0) + call iiswt (iischan, status) + if (status == ERR) + return + + # Read or write the data block. + npacked = ny * IIS_XDIM + szline = IIS_XDIM / (SZ_SHORT * SZB_CHAR) + + # Transmit the data byte-packed to increase the i/o bandwith + # when using network i/o. + + xferid = XFERID(hdr) + if (and (xferid, IREAD) != 0) { + # Read from the IIS. + + call zardgd (iischan, Memc[iobuf], npacked, 0) + call iiswt (iischan, status) + + # Unpack and line flip the packed data. + do i = 0, ny-1 + call achtbs (Memc[iobuf+i*szline], buf[1,ny-i], IIS_XDIM) + + } else { + # Write to the IIS. + + # Bytepack the image lines, doing a line flip in the process. + do i = 0, ny-1 + call achtsb (buf[1,ny-i], Memc[iobuf+i*szline], IIS_XDIM) + + call zawrgd (iischan, Memc[iobuf], npacked, 0) + } +end diff --git a/pkg/images/tv/iis/iism70/iisrange.x b/pkg/images/tv/iis/iism70/iisrange.x new file mode 100644 index 00000000..8fad856b --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisrange.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define LEN_RANGE 1 + +# IISRANGE -- Read and write range scaling registers +# Input data is of form 1-->range "0", 2,3 --> "1", 4-7 --> "2" +# and anything beyond 7 --> "4". This is just like zoom. +# However, on readback, the actual range values are returned. If +# this should change, the zsnapinit code must change too (the only +# place where a range read is done). + +procedure iisrange (rw, color, n, data) + +short rw # read or write +short color[ARB] # color +short n # number of data values +short data[ARB] # the data + +short range +int i, j +int command, x, itemp, ival +int and(), or() +include "iis.com" + +begin + if (data[1] == IDS_EOD) + return + + command = IREAD + x = ADVXONTC + + call iishdr (command, LEN_RANGE, OFM+COMMAND, x, 0, 0, 0) + call iisio (range, LEN_RANGE * SZB_CHAR) + + if (rw == IDS_WRITE) { + command = IWRITE+VRETRACE + j = 1 + for (i=1; color[i] != IDS_EOD; i=i+1) { + switch (data[j]) { + case 1,2: + ival = data[j]-1 + case 3: + ival = 1 + case 4,5,6,7: + ival = 2 + + default: + if (ival < 0) + ival = 0 + else + ival = 3 + } + + itemp = range + switch(color[i]) { + case IDS_RED: + range = or (ival*16, and (itemp, 17B)) + + case IDS_GREEN: + range = or (ival*4, and (itemp, 63B)) + + case IDS_BLUE: + range = or (ival, and (itemp, 74B)) + } + + if ( j < n) + j = j + 1 + } + + call iishdr (command, LEN_RANGE, OFM+COMMAND, x, 0, 0, 0) + call iisio (range, LEN_RANGE * SZB_CHAR) + + } else { + # Return a range value + j = 1 + for (i=1; i <= n; i=i+1) { + itemp = range + switch (color[j]) { + case IDS_RED: + data[i] = and (itemp, 60B) / 16 + + case IDS_GREEN: + data[i] = and (itemp, 14B) / 4 + + case IDS_BLUE: + data[i] = and (itemp, 3B) + } + j = j+1 + if (color[j] == IDS_EOD) + j = j - 1 + } + } +end diff --git a/pkg/images/tv/iis/iism70/iisrd.x b/pkg/images/tv/iis/iism70/iisrd.x new file mode 100644 index 00000000..20e99cb2 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisrd.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# IISRD -- Read data from IIS. Reads are packed when can. +# The data is line-flipped. + +procedure iisrd (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset + +long off1, off2 +int nchars, thing_count, tid, y1, y2, x +int or() +include "iis.com" + +begin + # Convert to chars and clip at the top of the display. + off1 = (offset - 1) / SZB_CHAR + 1 + off2 = min (IIS_XDIM * IIS_YDIM, (offset + nbytes - 1) / SZB_CHAR) + 1 + nchars = off2 - off1 + + y1 = (off1-1 ) / IIS_XDIM + y2 = (off2-1 - IIS_XDIM) / IIS_XDIM + y2 = max (y1,y2) + + # Pack only if start at x=0 + x = (off1 - 1) - y1 * IIS_XDIM + if ( x == 0 ) + tid = IREAD+PACKED + else + tid = IREAD + + # If only a few chars, don't pack...have trouble with count of 1 + # and this maeks code same as iiswr.x + if ( nchars < 4 ) + tid = IREAD + + thing_count = nchars + + call iishdr (tid, thing_count, REFRESH, + or (x, ADVXONTC), or (IIS_YDIM-1-y2, ADVYONXOV), iframe, iplane) + if ( tid == IREAD) + call iisio (buf, nbytes) + else + call iispio (buf, y2 - y1 + 1) +end diff --git a/pkg/images/tv/iis/iism70/iisscroll.x b/pkg/images/tv/iis/iism70/iisscroll.x new file mode 100644 index 00000000..a583e4a4 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iisscroll.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" +include "../lib/ids.h" + +# IISSCROLL -- Read and Write scroll registers +# We scroll multiple frames to multiple centers; if there are not +# enough data pairs to match the number of frames, use the last +# pair repeatedly. + +procedure iisscroll (rw, frame, n, data) + +short rw # read or write +short frame[ARB] # frame data +short n # number of data values +short data[ARB] # the data + +int z +short iispack() +int i,total, pl, index + +include "iis.com" + +begin + total = n/2 + if ( rw != IDS_WRITE) { + # Scroll registers are write only + do i = 1, total { + pl = frame[i] + if (pl == IDS_EOD) + break + data[2*i-1] = xscroll[pl] * MCXSCALE + data[2*i] = yscroll[pl] * MCYSCALE + } + + if (2*total < n) + data[2*total+1] = IDS_EOD + return + } + + # Set all the scroll offsets. + index = 1 + for (i=1; frame[i] != IDS_EOD; i=i+1) { + pl = frame[i] + xscroll[pl] = data[2*index-1] / MCXSCALE + yscroll[pl] = data[2*index ] / MCYSCALE + if (i < total) + index = index + 1 + } + + # Now do the scrolling. + for (i=1; frame[i] != IDS_EOD; i=i+1) { + pl = frame[i] + if (i == total) { + z = iispack (frame[i]) + call do_scroll (z, xscroll[pl], yscroll[pl]) + break + } else + call do_scroll (short(2**(pl-1)), xscroll[pl], yscroll[pl]) + } +end + + +procedure do_scroll (planes, x, y) + +short planes # bit map for planes +short x,y # where to scroll + +short command +short scr[2] +short xs,ys + +include "iis.com" + +begin + xs = x + ys = y + command = IWRITE+VRETRACE + scr[1] = xs + scr[2] = ys + + # If x/y scroll at "center", scr[1/2] are now IIS_[XY]CEN + # y = 0 is at top for device while y = 1 is bottom for user + # so for y, center now moves to IIS_YCEN_INV !! + + scr[2] = IIS_YDIM - 1 - scr[2] + + # Scroll is given for center, but hardware wants corner coords. + scr[1] = scr[1] - IIS_XCEN + scr[2] = scr[2] - IIS_YCEN_INV + + if (scr[1] < 0) + scr[1] = scr[1] + IIS_XDIM + if (scr[2] < 0) + scr[2] = scr[2] + IIS_YDIM + + call iishdr (command, 2, SCROLL, ADVXONTC, 0, int(planes), 0) + call iisio (scr, 2 * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/iissplit.x b/pkg/images/tv/iis/iism70/iissplit.x new file mode 100644 index 00000000..2badb7cb --- /dev/null +++ b/pkg/images/tv/iis/iism70/iissplit.x @@ -0,0 +1,68 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +define X_SPLIT 12 + +# IISSPLIT -- Read and Write split screen coordinates + +procedure iissplit (rw, n, data) + +short rw # read or write +short n # number of data values +short data[ARB] # the data + +int command,len,x +short coord[2] + +include "iis.com" + +begin + len = min (int(n), 2) + if ( len < 1) { + data[1] = IDS_EOD + return + } + + if (rw == IDS_WRITE) { + if (data[1] == IDS_EOD) + return + command = IWRITE+VRETRACE + coord[1] = data[1] / MCXSCALE + + + # Split screen will display the full screen from one lut ONLY + # if the split coordinate is zero. Setting the split to 511 + # means that all the screen BUT the last pixel is from one lut. + # Hence the y coordinate for full screen in one quad is + # (device) 0 , (user) 511. If the user requests split at (0,0), + # we honor this as a (device) (0,0). This will remove the + # ability to split the screen with just the bottom line + # in the "other" lut, which shouldn't bother anyone. + + if (len == 2) + coord[2] = (IIS_YDIM - 1) - data[2]/MCYSCALE + + if (coord[2] == IIS_YDIM - 1) + coord[2] = 0 + + } else + command = IREAD+VRETRACE + + # at most, read/write the x,y registers + x = X_SPLIT + ADVXONTC + + call iishdr (command, len, LUT+COMMAND, x, 0, 0, 0) + call iisio (coord, len * SZB_CHAR) + + if ( rw != IDS_WRITE ) { + data[1] = coord[1] * MCXSCALE + if ( len == 2 ) { + if ( coord[2] == 0) + coord[2] = IIS_YDIM - 1 + data[2] = (IIS_YDIM - 1 - coord[2] ) * MCYSCALE + } + } +end diff --git a/pkg/images/tv/iis/iism70/iistball.x b/pkg/images/tv/iis/iism70/iistball.x new file mode 100644 index 00000000..ebcc6566 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iistball.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# IISTBALL -- Read, Write tball status to turn tball on/off + +procedure iistball (rw, data) + +short rw # read or write +short data[ARB] # the data + +int command,len +short status +int and(), or() + +include "iis.com" + +begin + len = 1 + call iishdr (IREAD, len, CURSOR+COMMAND, 0, 0, 0, 0) + call iisio (status, len * SZB_CHAR) + if ( rw == IDS_WRITE) { + command = IWRITE+VRETRACE + switch (data[1]) { + case IDS_OFF: + status = and (int(status), 177771B) + + case IDS_ON: + status = or ( int(status), 6) + } + call iishdr (command, 1, CURSOR+COMMAND, 0, 0, 0, 0) + call iisio (status, 1 * SZB_CHAR) + } else { + if ( and ( int(status), 6) == 0 ) + data[2] = IDS_OFF + else + data[2] = IDS_ON + } +end diff --git a/pkg/images/tv/iis/iism70/iiswr.x b/pkg/images/tv/iis/iism70/iiswr.x new file mode 100644 index 00000000..11bb2803 --- /dev/null +++ b/pkg/images/tv/iis/iism70/iiswr.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# IISWR -- Write pixel data to IIS. Writes are packed with full lines only. +# The data is line-flipped, causing the first line to be displayed at the bottom +# of the screen. + +procedure iiswr (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset + +long off1, off2 +int nchars, thing_count, tid, y1, y2, x +int or() +include "iis.com" + +begin + # Convert to chars and clip at the top of the display. + off1 = (offset - 1) / SZB_CHAR + 1 + off2 = min (IIS_XDIM * IIS_YDIM, (offset + nbytes - 1) / SZB_CHAR) + 1 + nchars = off2 - off1 + + y1 = (off1-1 ) / IIS_XDIM + y2 = (off2-1 - IIS_XDIM) / IIS_XDIM + y2 = max (y1,y2) + + # Pack only if full lines + x = (off1 - 1) - y1 * IIS_XDIM + if ( x == 0 ) + tid = IWRITE+BYPASSIFM+PACKED+BLOCKXFER+BYTE + else + tid = IWRITE+BYPASSIFM + + # If only a few chars, don't pack (BLOCKXFER needs nchar>=4) + if ( nchars < 4 ) + tid = IWRITE+BYPASSIFM + + thing_count = nchars + + call iishdr (tid, thing_count, REFRESH, + or (x, ADVXONTC), or (IIS_YDIM-1-y2, ADVYONXOV), iframe, iplane) + if ( tid == IWRITE+BYPASSIFM) + call iisio (buf, nbytes) + else + call iispio (buf, y2 - y1 + 1) +end diff --git a/pkg/images/tv/iis/iism70/iiswt.x b/pkg/images/tv/iis/iism70/iiswt.x new file mode 100644 index 00000000..93f1e04a --- /dev/null +++ b/pkg/images/tv/iis/iism70/iiswt.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" + +# IISWT -- Wait for IIS display. + +procedure iiswt (chan, nbytes) + +int chan[ARB] +int nbytes +include "iis.com" + +begin + call zawtgd (iischan, nbytes) + nbytes = nbytes * SZB_CHAR +end diff --git a/pkg/images/tv/iis/iism70/iiszoom.x b/pkg/images/tv/iis/iism70/iiszoom.x new file mode 100644 index 00000000..d703beec --- /dev/null +++ b/pkg/images/tv/iis/iism70/iiszoom.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" +include "../lib/ids.h" + +# IISZOOM -- Read and Write zoom magnification and coordinates. +# the zoom coordinates give the point that should appear in the +# center of the screen. For the I2S model 70, this requires a +# scroll. In order for the scroll to be "determinable", we always +# set the I2S "zoom center" to (IIS_XCEN,IIS_YCEN_INV). The IIS_YCEN_INV +# results from specifying IIS_YCEN for y center and then having to "invert" y +# to put GKI(y) = 0 at bottom. +# This routine implements a command of the form "zoom these frames +# to the coordinates given, with each triple of data setting a +# zoom factor and a zoom center for the corresponding frame". +# If there are excess frames (rel. to "n"), use the last triple. + +procedure iiszoom (rw, frames, n, data) + +short rw # read or write +short frames[ARB] # which frames to zoom +short n # number of data values +short data[ARB] # the data + +int command,x +int i, total,pl,index +short zm,temp[4] +short scroll[2*IDS_MAXIMPL + 1] +short center[3] +# magnification, and "zoom center" +data temp /0,IIS_XCEN,IIS_YCEN_INV, 0/ +# center in GKI x=256 y=255 +data center/ 16384, 16320, 0/ + +include "iis.com" + +begin + total = n/3 + + if ( rw != IDS_WRITE) { + # hardware is write only + do i = 1, total { + index = (i-1) * 3 + 1 + pl = frames[i] + if ( pl == IDS_EOD) + break + data[index] = zoom[pl] + data[index+1] = xscroll[pl] * MCXSCALE + data[index+2] = yscroll[pl] * MCYSCALE + } + if ( 3*total < n) + data[index+3] = IDS_EOD + return + } + + # can't have in data statements as IDS_EOD == (-2) and + # fortran won't allow () in data statements!!! + + temp[4] = IDS_EOD + center[3] = IDS_EOD + command = IWRITE+VRETRACE + x = ADVXONTC + + # the model 70 zooms all frames together. So ignore "frames" + # argument here, though needed for subsequent scroll. + + zm = data[1] + if ( zm <= 1 ) + zm = 0 + else if (zm >= 8) + zm = 3 + else + switch(zm) { + case 2,3: + zm = 1 + + case 4,5,6,7: + zm = 2 + } + call amovks(short(2**zm), zoom, 16) + temp[1] = zm + call iishdr (command, 3, ZOOM, x, 0, 0, 0) + call iisio (temp, 3 * SZB_CHAR) + + # now we have to scroll to the desired location (in GKI). + # If zoom is zero, don't do anything: this will leave the + # various images panned to some previously set place, but + # that is what is wanted when doing split screen and we pan + # some of the images. + + if (zm != 0) { + do i = 1, total + call amovs (data[i * 3 - 1 ], scroll[i*2-1], 2) + scroll[total*2+1] = IDS_EOD + call iisscroll(short(IDS_WRITE), frames, short(total*2+1), scroll) + } +end diff --git a/pkg/images/tv/iis/iism70/mkpkg b/pkg/images/tv/iis/iism70/mkpkg new file mode 100644 index 00000000..9944d732 --- /dev/null +++ b/pkg/images/tv/iis/iism70/mkpkg @@ -0,0 +1,58 @@ +# Makelib file for the image display interface. An image display device is +# accessed by high level code via the GKI interface. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + idsexpand.x ../lib/ids.h iis.h + iisbutton.x iis.h ../lib/ids.h iis.com + iiscls.x iis.h iis.com + iiscursor.x iis.h ../lib/ids.h iis.com + iishdr.x iis.h iis.com + iishisto.x iis.h ../lib/ids.h iis.com + iisifm.x iis.h ../lib/ids.h iis.com + iisio.x iis.h iis.com + iislut.x iis.h ../lib/ids.h iis.com + iismatch.x iis.h ../lib/ids.h ../lib/ids.com + iisminmax.x iis.h ../lib/ids.h iis.com + iisoffset.x iis.h ../lib/ids.h iis.com + iisofm.x iis.h ../lib/ids.h iis.com + iisopn.x iis.h iis.com + iispack.x ../lib/ids.h + iispio.x iis.h iis.com + iisrange.x iis.h ../lib/ids.h iis.com + iisrd.x iis.h iis.com + iisscroll.x iis.h ../lib/ids.h iis.com + iissplit.x iis.h ../lib/ids.h iis.com + iistball.x iis.h ../lib/ids.h iis.com + iiswr.x iis.h iis.com + iiswt.x iis.h iis.com + iiszoom.x iis.h ../lib/ids.h iis.com + zardim.x iis.h + zawrim.x + zawtim.x iis.h iis.com + zclear.x ../lib/ids.h iis.h + zclsim.x + zcontrol.x ../lib/ids.h iis.h + zcursor_read.x iis.h ../lib/ids.h iis.com + zcursor_set.x iis.h ../lib/ids.h iis.com + zdisplay_g.x iis.h ../lib/ids.h + zdisplay_i.x iis.h ../lib/ids.h ../lib/ids.com iis.com + zinit.x iis.h ../lib/ids.h ../lib/ids.com iis.com + zopnim.x + zreset.x ../lib/ids.h iis.h iis.com + zrestore.x ../lib/ids.h iis.h + zsave.x ../lib/ids.h iis.h + zseek.x ../lib/ids.h iis.h + + zsetup.x ../lib/ids.h iis.h ../lib/ids.com\ + iis.com + zsnap.x iis.h ../lib/ids.h zsnap.com iis.com\ + ../lib/ids.com + zsnapinit.x iis.h ../lib/ids.h zsnap.com iis.com\ + ../lib/ids.com + zsttim.x + ; diff --git a/pkg/images/tv/iis/iism70/zardim.x b/pkg/images/tv/iis/iism70/zardim.x new file mode 100644 index 00000000..e6811840 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zardim.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iis.h" + +# ZARDIM -- Read data from a binary file display device. + +procedure zardim (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset + +begin + call iisrd (chan, buf, nbytes, offset) +end diff --git a/pkg/images/tv/iis/iism70/zawrim.x b/pkg/images/tv/iis/iism70/zawrim.x new file mode 100644 index 00000000..7e5fa266 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zawrim.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZAWRIM -- Write data to a binary file display device. + +procedure zawrim (chan, buf, nbytes, offset) + +int chan[ARB] +short buf[ARB] +int nbytes +long offset + +begin + call iiswr (chan, buf, nbytes, offset) +end diff --git a/pkg/images/tv/iis/iism70/zawtim.x b/pkg/images/tv/iis/iism70/zawtim.x new file mode 100644 index 00000000..ef857bdd --- /dev/null +++ b/pkg/images/tv/iis/iism70/zawtim.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "iis.h" + +# ZAWTIM -- Wait for an image display frame which is addressable as +# a binary file. + +procedure zawtim (chan, nbytes) + +int chan[ARB], nbytes +include "iis.com" + +begin + call iiswt (chan, nbytes) +end diff --git a/pkg/images/tv/iis/iism70/zclear.x b/pkg/images/tv/iis/iism70/zclear.x new file mode 100644 index 00000000..a03d429c --- /dev/null +++ b/pkg/images/tv/iis/iism70/zclear.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# ZCLEAR -- Erase IIS frame. + +procedure zclear (frame, bitplane, flag) + +short frame[ARB] # frame array +short bitplane[ARB] # bitplane array +bool flag # true if image plane + +int z, t +short erase +int and(), andi() +short iispack() + +begin + if (flag) { + z = iispack (frame) + z = and (z, ALLCHAN) + } else + z = GRCHAN + + t = iispack (bitplane) + erase = andi (ERASE, 177777B) + + call iishdr (IWRITE+BYPASSIFM+BLOCKXFER, 1, FEEDBACK, + ADVXONTC, ADVYONXOV, z, t) + call iisio (erase, SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/zclsim.x b/pkg/images/tv/iis/iism70/zclsim.x new file mode 100644 index 00000000..a2bd2029 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zclsim.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZCLSIM -- Close an image display frame which is addressable as +# a binary file. + +procedure zclsim (chan, status) + +int chan[ARB] +int status + +begin + call iiscls (chan, status) +end diff --git a/pkg/images/tv/iis/iism70/zcontrol.x b/pkg/images/tv/iis/iism70/zcontrol.x new file mode 100644 index 00000000..56d8caeb --- /dev/null +++ b/pkg/images/tv/iis/iism70/zcontrol.x @@ -0,0 +1,116 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" +include "iis.h" + +# ZCONTROL -- call the device dependent control routines + +procedure zcontrol(device, rw, frame, color, offset, n, data) + +short device # which device/register to control +short rw # write/read/wait,read +short frame[ARB] # array of image frames +short color[ARB] # array of color +short offset # generalized offset or datum +short n # count of items in data array +short data[ARB] # data array + +begin + switch(device) { + case IDS_FRAME_LUT: + call iislut(rw, frame, color, offset, n, data) + + case IDS_GR_MAP: + # for now, nothing + + case IDS_INPUT_LUT: + call iisifm(rw, offset, n, data) + + case IDS_OUTPUT_LUT: + call iisofm(rw, color, offset, n, data) + + case IDS_SPLIT: + call iissplit(rw, n, data) + + case IDS_SCROLL: + call iisscroll(rw, frame, n, data) + + case IDS_ZOOM: + call iiszoom(rw, frame, n, data) + + case IDS_OUT_OFFSET: + call iisoffset(rw, color, n, data) + + case IDS_MIN: + call iismin(rw, color, n, data) + + case IDS_MAX: + call iismax(rw, color, n, data) + + case IDS_RANGE: + call iisrange(rw, color, n, data) + + case IDS_HISTOGRAM: + call iishisto(rw, color, offset, n, data) + + case IDS_ALU_FCN: + # for now, nothing + + case IDS_FEEDBACK: + # for now, nothing + + case IDS_SLAVE: + # for now, nothing + + case IDS_CURSOR: + call iiscursor(rw, offset, n, data) + + case IDS_TBALL: + call iistball(rw, data) + + case IDS_DIGITIZER: + # for now, nothing + + case IDS_BLINK: + # for now, nothing + + case IDS_SNAP: + call zsnap_init(data[1]) + + case IDS_MATCH: + call iismatch (rw, frame, color, n, data) + } +end + + +# MAPCOLOR - modify the color array to map rgb for iis + +int procedure mapcolor(color) + +short color[ARB] # input data + +int i +int val, result +int or() + +begin + result = 0 + for ( i = 1; color[i] != IDS_EOD ; i = i + 1 ) { + val = color[i] + switch (val) { + case IDS_RED: + val = RED + + case IDS_GREEN: + val = GREEN + + case IDS_BLUE: + val = BLUE + + default: + val = 2**(val-1) + } + result = or (result, val) + } + return (result) +end diff --git a/pkg/images/tv/iis/iism70/zcursor_read.x b/pkg/images/tv/iis/iism70/zcursor_read.x new file mode 100644 index 00000000..6de5bc8e --- /dev/null +++ b/pkg/images/tv/iis/iism70/zcursor_read.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" +include "../lib/ids.h" + +# ZCURSOR_READ -- Read cursor from display. This assumes that the cursor +# is centered at (31,31) + +procedure zcursor_read (cnum, xcur, ycur, key) + +int cnum # cursor number +int xcur, ycur # cursor position...GKI coordinates +int key # key pressed + +short cursor[2] # local storage +real x,y +int frame +real zm +int mod(), and() +define exit_ 10 + +include "iis.com" + +begin + # Computations must be done in floating point when zoomed + # or values are off by a pixel. Also, want fractional + # pixel returned values in the zoomed case. + + call iishdr(IREAD, 2, COMMAND+CURSOR, 1+ADVXONTC, 0,0,0) + call iisio (cursor, 2 * SZB_CHAR) + + # which frame is the cursor relative to? We assume that cnum + # mod IDS_CSET refers to the image plane (graphics fits in + # here as an image plane for iism70), and cnum / IDS_CSET + # sets which cursor. + # If cursor is #0, then take lowest numbered frame that is + # being displayed. + # Return frame number as the "key". + + if (cnum == 0) { + frame = i_frame_on + if ((frame == ERR) || (frame < 1) ) { + key = ERR + return + } + } else if (cnum != IDS_CRAW) { + frame = mod(cnum-1, IDS_CSET) + 1 + } else { + zm = 1. + frame = 0 # return unusual frame num. if raw read + } + + # deal with cursor offset--hardware fault sometimes adds extra + # bit, so chop it off with and(). + x = mod (and (int(cursor[1]), 777B)+ 31, 512) + y = mod (and (int(cursor[2]), 777B)+ 31, 512) + + if (cnum == IDS_CRAW) + goto exit_ + + # x,y now in device coordinates for screen but not world. + # next, we determine number of pixels from screen center. + + zm = zoom[frame] + x = x/zm - IIS_XCEN./zm + y = y/zm - IIS_YCEN_INV./zm + + # Now add in scroll offsets, which are to screen center. + x = x + xscroll[frame] + + # Note that the Y one is inverted + y = y + (IIS_YDIM-1) - yscroll[frame] + + if (x < 0) + x = x + IIS_XDIM + else if (x > IIS_XDIM) + x = x - IIS_XDIM + + if (y < 0) + y = y + IIS_YDIM + else if (y > IIS_YDIM) + y = y - IIS_YDIM +exit_ + # invert y for user + y = (IIS_YDIM -1) - y + + # The Y inversion really complicates things... + y = y + 1.0 - (1.0/zm) + + # convert to GKI + xcur = x * MCXSCALE + ycur = y * MCYSCALE + key = frame +end diff --git a/pkg/images/tv/iis/iism70/zcursor_set.x b/pkg/images/tv/iis/iism70/zcursor_set.x new file mode 100644 index 00000000..50b1d446 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zcursor_set.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" +include "iis.h" + +# ZCURSOR_SET -- Write cursor to display. This code assumes the standard +# cursor which is centered on (31,31). + +procedure zcursor_set (cnum, xcur, ycur) + +int cnum # cursor number +int xcur, ycur # GKI x,y cursor position + +short cursor[2] # local storage +real x,y,zm +int xedge +int yedge, frame +int mod() +define output 10 + +include "iis.com" + +begin + # which frame does cursor refer to? ( see zcursor_read() for + # more information. ) + + if (cnum == IDS_CRAW) { + x = real(xcur)/MCXSCALE + y = real(ycur)/MCYSCALE + zm = 1 + xedge = 0 + yedge = 0 + goto output + } + + if (cnum == 0) { + frame = i_frame_on + if ((frame == ERR) || (frame < 1)) + return # WHAT SHOULD WE DO? + } else + frame = mod( cnum-1, IDS_CSET) + 1 + zm = zoom[frame] + + # Find the left/upper edge of the display + # xedge is real as we can't drop the fraction of IIS_XCEN/zm + # (This was true when XCEN was 255; now is 256 so can use int + # since 256 is a multiple of all possible values of zm.) + + xedge = xscroll[frame] - IIS_XCEN/zm + if (xedge < 0) + xedge = xedge + IIS_XDIM + yedge = ( (IIS_YDIM-1) - yscroll[frame]) - int(IIS_YCEN_INV/zm) + if (yedge < 0) + yedge = yedge + IIS_YDIM + + # xcur, ycur are in gki. Check if value too big...this will + # happen if NDC = 1.0, for instance which should be acceptable + # but will be "out of range". + + x = real(xcur)/MCXSCALE + if ( x > (IIS_XDIM - 1.0/zm) ) + x = IIS_XDIM - 1.0/zm + y = real(ycur)/MCYSCALE + if ( y > (IIS_YDIM - 1.0/zm) ) + y = IIS_YDIM - 1.0/zm + + # Invert y value to get device orientation; account for + # fractional pixels + +output + y = (IIS_YDIM - 1.0/zm) - y + + # Account for the mod 512 nature of the display + + if (x < xedge) + x = x + IIS_XDIM + if (y < yedge) + y = y + IIS_YDIM + + # Are we still on screen ? + + if ((x >= (xedge + IIS_XDIM/zm)) || (y >= (yedge + IIS_YDIM/zm)) ) { + call eprintf("cursor set off screen -- ignored\n") + return + } + + # Calculate cursor positioning coordinates. + + cursor[1] = int ((x-real(xedge)) * zm ) - 31 + if ( cursor[1] < 0 ) + cursor[1] = cursor[1] + IIS_XDIM + cursor[2] = int ((y-real(yedge)) * zm ) - 31 + if ( cursor[2] < 0 ) + cursor[2] = cursor[2] + IIS_YDIM + + call iishdr (IWRITE+VRETRACE, 2, COMMAND+CURSOR, 1+ADVXONTC, 0,0,0) + call iisio (cursor, 2 * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/zdisplay_g.x b/pkg/images/tv/iis/iism70/zdisplay_g.x new file mode 100644 index 00000000..21cf9e09 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zdisplay_g.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +define INSERT 100000B + +# ZDISPLAY_G -- Display the referenced graphics bitplanes in the given color(s) + +procedure zdisplay_g (sw, bitpl, color, quad ) + +short sw # on or off +short bitpl[ARB] # bitpl list +short color[ARB] # color list +short quad[ARB] # quadrants to activate + +short gram[LEN_GRAM] +bool off +int i, lbound, val +short mask[7] +short fill +# red a bit weak so have contrast with cursor +#colors of graph: blue grn red yellow rd-bl gn-bl white +data mask /37B, 1740B, 74000B, 77740B, 74037B, 1777B, 77777B/ + +begin + if ( sw == IDS_OFF ) + off = true + else { + off = false + } + + # ignore bitpl argument since only one set of them and "color" + # fully specifies them. + # ignore quad for now + # much manipulation of color graphics ram table required!! + # strictly speaking, when we turn a plane off, we ought to be + # sure that any plane which is on, and "beneath", is turned on; + # this is a lot of trouble, so for starters, we don't. + # first find out what is on + + call iishdr(IREAD+VRETRACE, LEN_GRAM, GRAPHICS, ADVXONTC, 0, 0, 0) + call iisio (gram, LEN_GRAM * SZB_CHAR) + + # Check for red graphics plane for cursor + + if ( gram[LEN_GRAM/2+1] != 176000B ) + call amovks ( short(176000B), gram[LEN_GRAM/2+1], LEN_GRAM/2) + + for ( i = 1 ; color[i] != IDS_EOD ; i = i + 1 ) { + # Bit plane 8 reserved for cursor + if ( color[i] > 7 ) + next + # map IDS colors to IIS bit planes -- one-based. + switch (color[i]) { + case IDS_RED: + val = RD + case IDS_GREEN: + val = GR + case IDS_BLUE: + val = BLU + default: + val = color[i] + } + lbound = 2 ** (val - 1) + if ( off ) + call aclrs ( gram[lbound+1], lbound) + else + call amovks ( short(INSERT+mask[val]), gram[lbound+1], lbound) + } + gram[1] = 0 + + # If a bit plane is off, reset it with next "lower" one, thus + # uncovering any planes masked by the one turned off. + + if (off) { + fill = 0 + do i = 2, LEN_GRAM/2 { + if (gram[i] == 0 ) + gram[i] = fill + else + fill = gram[i] + } + } + + # Write out the data + + call iishdr(IWRITE+VRETRACE, LEN_GRAM, GRAPHICS, ADVXONTC, 0, 0, 0) + call iisio (gram, LEN_GRAM * SZB_CHAR) +end diff --git a/pkg/images/tv/iis/iism70/zdisplay_i.x b/pkg/images/tv/iis/iism70/zdisplay_i.x new file mode 100644 index 00000000..e08db8c3 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zdisplay_i.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# ZDISPLAY_I -- Display the referenced image planes in the given color(s) +# and in the given quadrants of the screen. + +procedure zdisplay_i (sw, frames, color, quad) + +short sw # on or off +short frames[ARB] # frame list +short color[ARB] # color list +short quad[ARB] # quadrant list + + +bool off +short channels +short select[LEN_SELECT] +int q,c,index, temp +int mq # mapped quadrant +int mapquad() +short iispack() +int and(), or(), xor() + +include "iis.com" +include "../lib/ids.com" # for i_maxframes! only + +begin + if ( sw == IDS_ON ) { + off = false + } else + off = true + + # first find out what is on + call iishdr(IREAD+VRETRACE, LEN_SELECT, COMMAND+LUT, ADVXONTC, 0,0,0) + call iisio (select, LEN_SELECT * SZB_CHAR) + + # then add in/remove frames + channels = iispack(frames) + + for ( q = 1 ; quad[q] != IDS_EOD ; q = q + 1 ) { + mq = mapquad(quad[q]) + if ( ! off ) { + for ( c =1 ; color[c] != IDS_EOD ; c = c + 1 ) { + switch ( color[c] ) { + case IDS_RED: + index = mq + 8 + + case IDS_GREEN: + index = mq + 4 + + case IDS_BLUE: + index = mq + } + select[index] = or ( int(channels), int(select[index]) ) + } + } else { + for ( c =1 ; color[c] != IDS_EOD ; c = c + 1 ) { + switch ( color[c] ) { + case IDS_RED: + index = mq + 8 + + case IDS_GREEN: + index = mq + 4 + + case IDS_BLUE: + index = mq + } + select[index] = and ( xor ( 177777B, int(channels)), + int(select[index])) + } + } + } + + # Record which frame is being displayed for cursor readback. + temp = 0 + do q = 1, LEN_SELECT + temp = or (temp, int(select[q])) + + if ( temp == 0) + i_frame_on = ERR + else { + do q = 1, i_maxframes { + if (and (temp, 2**(q-1)) != 0) { + i_frame_on = q + break + } + } + } + call iishdr(IWRITE+VRETRACE, LEN_SELECT, COMMAND+LUT, ADVXONTC, 0,0,0) + call iisio (select, LEN_SELECT * SZB_CHAR) +end + + +# MAPQUAD -- map user quadrant to device ... returns ONE-based quadrant +# if prefer ZERO-based, add one to "index" computation above. + +int procedure mapquad (quadrant) + +short quadrant + +int mq + +begin + switch ( quadrant ) { + case 1: + mq = 2 + + case 2: + mq = 1 + + case 3: + mq = 3 + + case 4: + mq = 4 + + default: + mq = 1 # should never happen + } + return (mq) +end diff --git a/pkg/images/tv/iis/iism70/zinit.x b/pkg/images/tv/iis/iism70/zinit.x new file mode 100644 index 00000000..e03fd57c --- /dev/null +++ b/pkg/images/tv/iis/iism70/zinit.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# ZINIT -- initialize for IIS operation +# in general case, would use nfr and ngr to determine maximum file size +# which would encompass all the images and graphics planes and all the +# devices too. Then, file mapped i/o could move most of the device indep. +# code to the reading and writing routines. +# not done for IIS + +procedure zinit (nfr, ngr, filesize) + +short nfr # maximum number of image frames +short ngr # maximum number of graphics bit planes +long filesize # returned value + +short pl[IDS_MAXIMPL+2] +short zm[4] + +include "../lib/ids.com" +include "iis.com" + +begin + i_snap = false + # we have no place to store all the zoom and scroll information. + # so we initialize to zoom = 1 and scroll = center for all planes + pl[1] = IDS_EOD + call ids_expand(pl, i_maxframes, true) + zm[1] = 1 + zm[2] = IIS_XCEN * MCXSCALE + zm[3] = IIS_YCEN * MCYSCALE + zm[4] = IDS_EOD + call iiszoom(short(IDS_WRITE), pl, short(4), zm) + call iisscroll(short(IDS_WRITE), pl, short(3), zm[2]) + + # We also need to set the i_frame_on variable (iis.com), which + # we do with a "trick": We call zdisplay_i with quad == EOD; + # this is a "nop" for the display code, but will set the variable. + + call zdisplay_i (short(IDS_ON), short(IDS_EOD), short(IDS_EOD), + short(IDS_EOD)) +end diff --git a/pkg/images/tv/iis/iism70/zopnim.x b/pkg/images/tv/iis/iism70/zopnim.x new file mode 100644 index 00000000..25df2f21 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zopnim.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# ZOPNIM -- Open an image display frame which is addressable as +# a binary file. + +procedure zopnim (devinfo, mode, chan) + +char devinfo[ARB] # packed devinfo string +int mode # access mode +int chan + +int iischan[2] # Kludge + +begin + call iisopn (devinfo, mode, iischan) + chan = iischan[1] +end diff --git a/pkg/images/tv/iis/iism70/zreset.x b/pkg/images/tv/iis/iism70/zreset.x new file mode 100644 index 00000000..3d067d04 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zreset.x @@ -0,0 +1,164 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" +include "iis.h" + +# cfactor is conversion from integer to NDC coordinates (max 32767) for cursor +# see iiscursor.x +# The "hardness" notion is now somewhat obsolete...a range of reset values +# would be better, especially if better named. + +define CFACTOR 528 + +# ZRESET -- reset IIS + +procedure zreset (hardness) + +short hardness # soft, medium, hard + +short data[LEN_IFM] +short frames[IDS_MAXIMPL+1] +short colors[IDS_MAXGCOLOR+1] +short quad[5] +int i,j + +include "iis.com" + +begin + if ( hardness == IDS_R_SNAPDONE ) { + call zsnap_done + return + } + + # mark all frames + do i = 1,IDS_MAXIMPL + frames[i] = i + frames[IDS_MAXIMPL+1] = IDS_EOD + # mark all colors + do i = 1, IDS_MAXGCOLOR + colors[i] = i + colors[IDS_MAXGCOLOR+1] = IDS_EOD + # all quadrants + do i = 1,4 + quad[i] = i + quad[5] = IDS_EOD + + if ( hardness == IDS_R_SOFT) { + # all coordinates are NDC ( 0 - 32767 ) + # Reseting the "soft" parameters: scroll, constant offsets, + # split point, alu, zoom; turn cursor and tball on. + + # constants + call aclrs (data,3) + call iisoffset(short(IDS_WRITE), colors, short(3), data) + + # range + data[1] = 1 + call iisrange (short(IDS_WRITE), colors, short(1), data) + + # split point + call aclrs ( data, 2) + call iissplit(short(IDS_WRITE), short(2), data) + + # alu + data[1] = 0 + call iishdr(IWRITE, 1, ALU+COMMAND, 0, 0, 0, 0) + call iisio (data, 1 * SZB_CHAR) + + # graphics status register + data[1] = 0 + call iishdr(IWRITE, 1, GRAPHICS+COMMAND, 0, 0, 0, 0) + call iisio (data, 1 * SZB_CHAR) + + # zoom + data[1] = 1 + data[2] = IIS_XCEN * MCXSCALE # gki mid point + data[3] = IIS_YCEN * MCYSCALE + data[4] = IDS_EOD + call iiszoom(short(IDS_WRITE), frames, short(4), data) + + # scroll -- screen center to be centered + # zoom does affect scroll if zoom not power==1 + # so to be safe, do scroll after zoom. + data[1] = IIS_XCEN * MCXSCALE + data[2] = IIS_YCEN * MCYSCALE + data[3] = IDS_EOD + call iisscroll(short(IDS_WRITE), frames, short(3), data) + + # cursor and tball; no blink for cursor + data[1] = IDS_ON + call iiscursor(short(IDS_WRITE), short(1), short(1), data) + call iistball (short(IDS_WRITE), data) + data[1] = IDS_CBLINK + data[2] = IDS_CSTEADY + call iiscursor(short(IDS_WRITE), short(1), short(1), data) + + # standard cursor shape + data[1] = IDS_CSHAPE + j = 2 + # don't use last line/column so have a real center + for ( i = 0 ; i <= 62 ; i = i + 1 ) { + # make the puka in the middle + if ( (i == 30) || (i == 31) || (i == 32) ) + next + # fill in the lines + data[j] = 31 * CFACTOR + data[j+1] = i * CFACTOR + j = j + 2 + data[j] = i * CFACTOR + data[j+1] = 31 * CFACTOR + j = j + 2 + } + data[j] = IDS_EOD + call iiscursor ( short(IDS_WRITE), short(1), short(j), data) + + return + } + + if ( hardness == IDS_R_MEDIUM) { + # reset all tables to linear--ofm, luts, ifm + # ofm (0,0) to (0.25,1.0) to (1.0,1.0) + data[1] = 0 + data[2] = 0 + data[3] = 0.25 * GKI_MAXNDC + data[4] = GKI_MAXNDC + data[5] = GKI_MAXNDC + data[6] = GKI_MAXNDC + call iisofm(short(IDS_WRITE), colors, short(1), short(6), data) + + # luts + data[1] = 0 + data[2] = 0 + data[3] = GKI_MAXNDC + data[4] = GKI_MAXNDC + call iislut(short(IDS_WRITE), frames, colors, short(1), + short(4), data) + + # ifm (0,0) to (1/32, 1.0) to (1.,1.) + # ifm is length 8192, but output is only 255. So map linearly for + # first 256, then flat. Other possibility is ifm[i] = i-1 ( for + # i = 1,8192) which relies on hardware dropping high bits. + + data[1] = 0 + data[2] = 0 + data[3] = (1./32.) * GKI_MAXNDC + data[4] = GKI_MAXNDC + data[5] = GKI_MAXNDC + data[6] = GKI_MAXNDC + call iisifm(short(IDS_WRITE), short(1), short(6), data) + + return + } + + if (hardness == IDS_R_HARD) { + # clear all image/graph planes, and set channel selects to + # mono + call zclear(frames, frames, true) + call zclear(frames, frames, false) + # reset all to no display + call zdisplay_i(short(IDS_OFF), frames, colors, quad) + call zdisplay_g(short(IDS_OFF), frames, colors, quad) + } +end diff --git a/pkg/images/tv/iis/iism70/zrestore.x b/pkg/images/tv/iis/iism70/zrestore.x new file mode 100644 index 00000000..ed478a20 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zrestore.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# restore device, image, graphics data + +procedure zdev_restore(fd) + +int fd # file descriptor to read from + +begin +end + +procedure zim_restore(fd, frame) + +int fd +short frame[ARB] # frame numbers to restore + +begin +end + +procedure zgr_restore(fd, plane) + +int fd +short plane[ARB] + +begin +end diff --git a/pkg/images/tv/iis/iism70/zsave.x b/pkg/images/tv/iis/iism70/zsave.x new file mode 100644 index 00000000..666f1b1f --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsave.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" +include "iis.h" + +# save device, image, graphics data + +procedure zdev_save(fd) + +int fd # file descriptor to write to + +begin +end + +procedure zim_save(fd, frame) + +int fd +short frame[ARB] # frame numbers to save + +begin +end + +procedure zgr_save(fd, plane) + +int fd +short plane[ARB] + +begin +end diff --git a/pkg/images/tv/iis/iism70/zseek.x b/pkg/images/tv/iis/iism70/zseek.x new file mode 100644 index 00000000..6f3fed25 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zseek.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" +include "iis.h" + +# ZSEEK -- Seek for an image frame + +procedure zseek (fd, x, y) + +int fd # file to write +int x, y # device coordinates + +long offset + +begin + offset = max (1, 1 + (x + y * IIS_XDIM) * SZ_SHORT) + + call seek (fd, offset) +end diff --git a/pkg/images/tv/iis/iism70/zsetup.x b/pkg/images/tv/iis/iism70/zsetup.x new file mode 100644 index 00000000..0803ac3a --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsetup.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" +include "iis.h" + +# ZSETUP -- Setup up common block information for read/write + +procedure zsetup (frame, bitpl, flag) + +short frame[ARB] # frame information +short bitpl[ARB] # bitplane information +bool flag # true if image, false if graphics + +short iispack() +int mapcolor() + +include "iis.com" +include "../lib/ids.com" + +begin + # If don't flush, then last line of "previous" frame + # may get steered to wrong image plane + call flush (i_out) + call fseti (i_out, F_CANCEL, OK) + if ( flag ) { + iframe = iispack ( frame ) + iplane = iispack ( bitpl ) + } else { + iframe = GRCHAN + iplane = mapcolor( bitpl ) + } +end diff --git a/pkg/images/tv/iis/iism70/zsnap.com b/pkg/images/tv/iis/iism70/zsnap.com new file mode 100644 index 00000000..8dd6796c --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsnap.com @@ -0,0 +1,26 @@ +# snap common block +int sn_fd # device file descriptor +int sn_frame, sn_bitpl # save current iframe, iplane +int zbufsize # fio buffer size--save here +pointer lutp[3,LEN_IISFRAMES] # look up table storage +pointer ofmp[3] # rgb ofm tables +pointer grp[3] # graphics tables +pointer result[3] # rgb results +pointer answer # final answer +pointer input # input data +pointer zs # zoom/scrolled data; scratch +pointer grbit_on # graphics bit on +bool gr_in_use # graphics RAM not all zeroes +bool on[LEN_IISFRAMES] # if frames on at all +bool multi_frame # snap using >1 frame +short range[3] # range and offset for rgb +short offset[3] +short left[3,2,LEN_IISFRAMES] # left boundary of line +short right[3,2,LEN_IISFRAMES] # right boundary of line +short ysplit # split point for y +short prev_y # previous line read +short sn_start, sn_end # color range to snap + +common / zsnap / sn_fd, sn_frame, sn_bitpl, zbufsize, lutp, ofmp, grp, + result, answer, input, zs, grbit_on, gr_in_use, on, multi_frame, + range, offset, left, right, ysplit, prev_y, sn_start, sn_end diff --git a/pkg/images/tv/iis/iism70/zsnap.x b/pkg/images/tv/iis/iism70/zsnap.x new file mode 100644 index 00000000..c0f9b230 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsnap.x @@ -0,0 +1,239 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" +include "../lib/ids.h" + +# DO_SNAP -- Return a line of the active image display, as seen +# by the viewer. + +procedure do_snap (buf, nchar, xpos, ypos) + +short buf[ARB] # buffer to read into +int nchar # how many to read +int xpos, ypos # and from where + +int y, yindex, xs, xe +int line, previous +int i,j +int yedge +int zm, count +bool first + +include "../lib/ids.com" +include "iis.com" +include "zsnap.com" + +begin + # Check if read is for one line only + + if (nchar > IIS_XDIM) { + call eprintf("ZSNAP -- too many pixels (%d) requested.\n") + call pargi (nchar) + call aclrs (buf, nchar) + return + } + + # Determine x and y coordinates on screen. + + y = IIS_YDIM - 1 - ypos + xs = xpos + xe = xs + nchar - 1 + count = nchar + + # See if we are dealing with (a part of only) one line + + if (xe >= IIS_XDIM) { + call eprintf("ZSNAP -- line overlap error (xend is %d).\n") + call pargi (xe) + call aclrs (buf, nchar) + return + } + + # Determine whether above or below split point. + + if (y < ysplit) + yindex = 1 + else + yindex = 2 + + # Clear accumulators + + do j = sn_start, sn_end + call aclrs (Mems[result[j]], IIS_XDIM) + + # Fetch and massage data for each active frame + + first = true + previous = -1 # a bit of safety if no frames on + do i = 1, i_maxframes { + if (on[i]) { + # If frame not active in any color for this half of screen, + # ignore it + if (sn_start != sn_end) { + if ((left[BLU, yindex, i] == -1) && + (left[GR , yindex, i] == -1) && + (left[RD , yindex, i] == -1) ) + next + } else if (left[sn_start, yindex, i] == -1) + next + + zm = zoom[i] + iplane = 377B # all bit planes + iframe = 2**(i-1) + + # y edge of frame (top) [ see zcursor_set for more information] + yedge = IIS_YCEN - yscroll[i] + IIS_YCEN_INV - IIS_YCEN_INV/zm + if (yedge < 0) + yedge = yedge + IIS_YDIM + + # Desired y (screen) coordinate + line = yedge + y/zm + if (line >= IIS_YDIM) + line = line - IIS_YDIM + # If have done this line before, just return the same answer + + if (first) { + if (line == prev_y) { + call amovs (Mems[answer], buf, nchar) + return + } + previous = line + first = false + } + + # Turn line into file position. + line = IIS_YDIM - 1 - line + if (multi_frame) + call fseti (sn_fd, F_CANCEL, OK) + call zseek (sn_fd, xs, line) + call read (sn_fd, Mems[input], count) + call zmassage (zm, xscroll[i], yindex, i, xs, xe) + } + } + + # Apply scaling + + do j = sn_start, sn_end { + # Note...xs, xe are zero-based indices + if ( offset[j] != 0) + call aaddks (Mems[result[j]+xs], offset[j], + Mems[result[j]+xs], count) + if ( range[j] != 1) + call adivks (Mems[result[j]+xs], range[j], + Mems[result[j]+xs], count) + call aluts (Mems[result[j]+xs], Mems[result[j]+xs], count, + Mems[ofmp[j]]) + } + + # Or in the graphics ... use of "select" (asel) depends on design + # decision in zdisplay_g.x + + if (gr_in_use) { + iframe = GRCHAN + iplane = 177B # ignore cursor plane + zm = zoom[GRCHNUM] + + yedge = IIS_YCEN - yscroll[GRCHNUM] + IIS_YCEN_INV - IIS_YCEN_INV/zm + if (yedge < 0) + yedge = yedge + IIS_YDIM + + line = yedge + y/zm + if (line >= IIS_YDIM) + line = line - IIS_YDIM + line = IIS_YDIM - 1 - line + + if (multi_frame) + call fseti (sn_fd, F_CANCEL, OK) + + call zseek (sn_fd, xs, line) + call read (sn_fd, Mems[input], count) + call zmassage (zm, xscroll[GRCHNUM], yindex, GRCHNUM, xs, xe) + + do j = sn_start, sn_end { + call aluts (Mems[input+xs], Mems[zs], count, Mems[grp[j]]) + + # Build boolean which says if have graphics on + call abneks (Mems[zs], short(0), Memi[grbit_on], count) + + # With INSERT on: replace data with graphics. + call asels (Mems[zs], Mems[result[j]+xs], Mems[result[j]+xs], + Memi[grbit_on], count) + } + } + + # The answer is: + + if (sn_start != sn_end) { + call aadds (Mems[result[BLU]], Mems[result[GR]], + Mems[answer], IIS_XDIM) + call aadds (Mems[answer], Mems[result[RD]], Mems[answer], IIS_XDIM) + call adivks (Mems[answer], short(3), Mems[answer], IIS_XDIM) + } else { + # Put in "answer" so repeated lines are in known location + call amovs (Mems[result[sn_start]], Mems[answer], nchar) + } + + # Set the previous line and return the answer + + prev_y = previous + call amovs (Mems[answer], buf, nchar) +end + + +# ZMASSAGE --- do all the boring massaging of the data: zoom, scroll, look +# up tables. + +procedure zmassage (zm, xscr, yi, i, xstart, xend) + +int zm # zoom factor +short xscr # x scroll +int yi # y-index +int i # frame index +int xstart, xend # indices for line start and end + +int lb, count # left bound, count of number of items +int j, x1, x2, itemp +include "zsnap.com" + +begin + if ( (xscr != IIS_XCEN) || (zm != 1)) { + if (xscr == IIS_XCEN) + # Scrolling not needed + call amovs (Mems[input], Mems[zs], IIS_XDIM) + else { + # Scroll the data + lb = xscr - IIS_XCEN + if ( lb < 0 ) + lb = lb + IIS_XDIM + count = IIS_XDIM - lb + call amovs (Mems[input+lb], Mems[zs], count) + call amovs (Mems[input], Mems[zs+count], lb) + } + # Now zoom it + if (zm == 1) + call amovs (Mems[zs], Mems[input], IIS_XDIM) + else + call ids_blockit (Mems[zs+IIS_XCEN-IIS_XCEN/zm], Mems[input], + IIS_XDIM, real(zm)) + } + + if (i == GRCHNUM) + return + + # With the aligned data, perform the lookup. Note that left is + # 0 based, right is (0-based) first excluded value. + + do j = sn_start, sn_end { + if (left[j, yi, i] == -1) + next + itemp = left[j,yi,i] + x1 = max (itemp, xstart) + itemp = right[j,yi,i] + x2 = min (itemp - 1, xend) + call aluts (Mems[input+x1], Mems[zs], x2-x1+1, Mems[lutp[j,i]]) + call aadds (Mems[zs], Mems[result[j]+x1], Mems[result[j]+x1], + x2-x1+1) + } +end diff --git a/pkg/images/tv/iis/iism70/zsnapinit.x b/pkg/images/tv/iis/iism70/zsnapinit.x new file mode 100644 index 00000000..48ed083c --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsnapinit.x @@ -0,0 +1,314 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "iis.h" +include "../lib/ids.h" + +define XSPLIT LEN_SELECT+1 +define YSPLIT LEN_SELECT+2 + +# ZSNAP_INIT -- initialize snap data structures. + +procedure zsnap_init(kind) + +short kind + +pointer ptr +short gram[LEN_GRAM] +short select[LEN_SELECT+2] # include split points +short color[4] +short frame[2] +short cds, off, num +short xsplit, x_right + +int i, j, k, temp +int khp, val, frame_count +bool used, mono +int and(), or(), fstati() + +include "zsnap.com" +include "iis.com" +include "../lib/ids.com" + +begin + i_snap = true + sn_frame = iframe + sn_bitpl = iplane + sn_fd = i_out + call flush(sn_fd) + call fseti(sn_fd, F_CANCEL, OK) + prev_y = -1 + + # Determine what snap range to do + if (kind == IDS_SNAP_MONO) + mono= true + else + mono = false + + switch (kind) { + case IDS_SNAP_RGB: + # Note: BLU < RD and covers full color range + sn_start = BLU + sn_end = RD + + case IDS_SNAP_MONO, IDS_SNAP_BLUE: + sn_start = BLU + sn_end = BLU + + case IDS_SNAP_GREEN: + sn_start = GR + sn_end = GR + + case IDS_SNAP_RED: + sn_start = RD + sn_end = RD + } + + # Find out which planes are active -- any quadrant + + call iishdr (IREAD, LEN_SELECT+2, COMMAND+LUT, ADVXONTC, 0, 0, 0) + call iisio (select, (LEN_SELECT+2)*SZB_CHAR) + + # record split point. Adjust x_split so 511 becomes + # 512. This is so the "right" side of a quadrant is given by one + # plus the last used point. + + ysplit = select[YSPLIT] + xsplit = select[XSPLIT] + x_right = xsplit + if (x_right == IIS_XDIM-1) + x_right = IIS_XDIM + + + # For certain split positions, some quadrants don't appear at all. + + if (xsplit == 0) + call nullquad (0, 2, select) + else if (xsplit == IIS_XDIM-1) + call nullquad (1, 3, select) + if (ysplit == 0) + call nullquad (0, 1, select) + else if (ysplit == IIS_YDIM-1) + call nullquad (2, 3, select) + + # Which frames are active, in any quadrant? + + temp = 0 + do i = 1, LEN_SELECT + temp = or (temp, int(select[i])) + do i = 1, i_maxframes { + if ( and (temp, 2**(i-1)) != 0) + on[i] = true + else + on[i] = false + } + + # Find out where each active plane starts and stops. Split points + # are screen coordinates, not picture coordinates. Graphics does + # not split (!). left coord is inclusive, right is one beyond end. + # left/right dimensions: color, above/below_ysplit, image_plane. + # Frame_count counts frames in use. Could be clever and only count + # active frames whose pixels are on the screen (pan/zoom effects). + + frame_count = 0 + do i = 1, i_maxframes { + if ( !on[i] ) + next + else + frame_count = frame_count + 1 + do j = sn_start, sn_end { # implicit BLUE (GREEN RED) + # quadrants for IIS are UL:0, UR:1, LL:2, LR:3 + do k = 0, 3 { + temp = select[(j-1)*4 + k + 1] + used = (and(temp, 2**(i-1)) != 0) + khp = k/2 + 1 + switch (k) { + case 0, 2: + if (used) { + left[j,khp,i] = 0 + right[j,khp,i] = x_right + } else { + left[j,khp,i] = -1 + } + + case 1, 3: + if (used) { + if ( left[j,khp,i] == -1) + left[j,khp,i] = xsplit + right[j,khp,i] = IIS_XDIM + } + } # end switch + } # end k ( quad loop) + } # end j ( color loop) + } # end i ( frame loop) + + # now do range and offset + + cds = IDS_READ + num = 3 + color[1] = IDS_BLUE + color[2] = IDS_GREEN + color[3] = IDS_RED + color[4] = IDS_EOD + call iisrange(cds, color, num, range) + call iisoffset(cds, color, num, offset) + do i = sn_start, sn_end + range[i] = 2**range[i] + + # now allocate memory for all the various tables + + call malloc (input, IIS_XDIM, TY_SHORT) + call malloc (answer, IIS_XDIM, TY_SHORT) + call malloc (zs, IIS_XDIM, TY_SHORT) + # for each color: + do j = sn_start, sn_end { + call malloc (result[j], IIS_XDIM, TY_SHORT) + call malloc (ofmp[j], LEN_OFM, TY_SHORT) + call malloc (grp[j], LEN_GRAM/2, TY_SHORT) + do i = 1, i_maxframes { + if ( on[i] ) + call malloc (lutp[j,i], LEN_LUT, TY_SHORT) + } + } + call malloc (grbit_on, IIS_XDIM, TY_INT) + + # fill these up + + cds = IDS_READ + off = 1 + frame[2] = IDS_EOD + color[2] = IDS_EOD + do j = sn_start, sn_end { + if (j == BLU) + color[1] = IDS_BLUE + else if ( j == GR) + color[1] = IDS_GREEN + else + color[1] = IDS_RED + num = LEN_OFM + call iisofm (cds, color, off, num, Mems[ofmp[j]]) + do i = 1, i_maxframes { + if (on[i]) { + frame[1] = i + num = LEN_LUT + call iislut (cds, frame, color, off, num, Mems[lutp[j,i]]) + } + } + } + + # the graphics planes ... assume insert mode!! + # Note if any graphics mapping ram is in use...if no graphics on, + # snap can run faster. + + call iishdr (IREAD, LEN_GRAM, GRAPHICS, ADVXONTC, 0, 0, 0) + call iisio (gram, LEN_GRAM * SZB_CHAR) + + gr_in_use = false + do j = sn_start, sn_end + call aclrs(Mems[grp[j]], LEN_GRAM/2) + # Leave first one 0; don't mess with cursor plane + do i = 2, LEN_GRAM/2 { + temp = and (77777B, int(gram[i])) + if (temp != 0) + gr_in_use = true + if (! mono) { + do j = sn_start, sn_end + switch (j) { + case RD: + Mems[grp[RD]+i-1] = and (temp,76000B)/32 + case GR: + Mems[grp[GR]+i-1] = and (temp, 1740B) + case BLU: + Mems[grp[BLU]+i-1] = and (temp, 37B)*32 + } + } else { + # All graphics planes + val = or ( and (temp, 76000B)/32, and (temp, 1740B)) + val = or ( and (temp, 37B)*32, val) + Mems[grp[sn_start]+i-1] = val + } + } + + if (gr_in_use) + frame_count = frame_count + 1 + if (frame_count > 1) { + multi_frame = true + # set buffer to size of one line + zbufsize = fstati (sn_fd, F_BUFSIZE) + call fseti (sn_fd, F_BUFSIZE, IIS_XDIM) + } else + multi_frame = false + + # Now adjust look up tables for fact that they do 9 bit 2's complement + # arithmetic! + do j = sn_start, sn_end { + do i = 1, i_maxframes { + if (on[i]) { + ptr = lutp[j,i] + do k = 1, LEN_LUT { + if (Mems[ptr+k-1] > 255 ) + Mems[ptr+k-1] = Mems[ptr+k-1] - 512 + } + } + } + } +end + + +# NULLQUAD -- zero out lut mapping for quadrants that cannot appear on +# screen + +procedure nullquad (q, p, sel) + +int q, p # two quadrants to eliminate, zero based +short sel[ARB] # the mapping array + +int i + +begin + do i = 0,2 { + sel[i*4 + q + 1] = 0 + sel[i*4 + p + 1] = 0 + } +end + + +# ZSNAP_DONE -- reset paramters + +procedure zsnap_done() + +int i,j + +include "iis.com" +include "zsnap.com" +include "../lib/ids.com" + +begin + if ( ! i_snap ) + return + i_snap = false + call fseti(sn_fd, F_CANCEL, OK) + if (multi_frame) { + # restore buffering + call fseti (sn_fd, F_BUFSIZE, zbufsize) + } + iframe = sn_frame + iplane = sn_bitpl + + # release storage + call mfree (grbit_on, TY_INT) + do j = sn_start, sn_end { + call mfree (result[j], TY_SHORT) + call mfree (ofmp[j], TY_SHORT) + call mfree (grp[j], TY_SHORT) + do i = 1, i_maxframes { + if ( on[i] ) + call mfree (lutp[j,i], TY_SHORT) + } + } + + call mfree (zs, TY_SHORT) + call mfree (answer, TY_SHORT) + call mfree (input, TY_SHORT) +end diff --git a/pkg/images/tv/iis/iism70/zsttim.x b/pkg/images/tv/iis/iism70/zsttim.x new file mode 100644 index 00000000..2f441ed7 --- /dev/null +++ b/pkg/images/tv/iis/iism70/zsttim.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# ZSTTIM -- Return status on binary file display device. + +procedure zsttim (chan, what, lvalue) + +int chan[ARB], what +long lvalue + +begin + call zsttgd (chan, what, lvalue) +end diff --git a/pkg/images/tv/iis/lib/ids.com b/pkg/images/tv/iis/lib/ids.com new file mode 100644 index 00000000..cd6bc086 --- /dev/null +++ b/pkg/images/tv/iis/lib/ids.com @@ -0,0 +1,25 @@ +# IDS common. A common is necessary since there is no graphics descriptor +# in the argument list of the kernel procedures. The data structures +# are designed along the lines of FIO: a small common is used to hold the time +# critical data elements, and an auxiliary dynamically allocated descriptor is +# used for everything else. + +pointer i_kt # kernel image display descriptor +pointer i_tty # graphcap descriptor +int i_in, i_out # input file, output file +int i_xres, i_yres # desired device resolution +long i_frsize # frame size in chars +short i_maxframes, i_maxgraph # max num. of image frames, gr. planes +int i_linemask # current linemask +int i_linewidth # current line width +int i_linecolor # current line color +short i_pt_x, i_pt_y # current plot point, device coords +int i_csize # text character size +int i_font # text font +bool i_snap # true if a snap in progress +bool i_image # frame/bitplane data is for image +char i_device[SZ_IDEVICE] # force output to named device + +common /idscom/ i_kt, i_tty, i_in, i_out, i_xres, i_yres, i_frsize, + i_maxframes, i_maxgraph, i_linemask, i_linewidth, i_linecolor, + i_pt_x, i_pt_y, i_csize, i_font, i_snap, i_image, i_device diff --git a/pkg/images/tv/iis/lib/ids.h b/pkg/images/tv/iis/lib/ids.h new file mode 100644 index 00000000..bbf36392 --- /dev/null +++ b/pkg/images/tv/iis/lib/ids.h @@ -0,0 +1,175 @@ +# IDS definitions. + +define MAX_CHARSIZES 10 # max discreet device char sizes +define SZ_SBUF 1024 # initial string buffer size +define SZ_IDEVICE 31 # maxsize forced device name + +# The IDS state/device descriptor. + +define LEN_IDS 81 + +define IDS_SBUF Memi[$1] # string buffer +define IDS_SZSBUF Memi[$1+1] # size of string buffer +define IDS_NEXTCH Memi[$1+2] # next char pos in string buf +define IDS_NCHARSIZES Memi[$1+3] # number of character sizes +define IDS_POLYLINE Memi[$1+4] # device supports polyline +define IDS_POLYMARKER Memi[$1+5] # device supports polymarker +define IDS_FILLAREA Memi[$1+6] # device supports fillarea +define IDS_CELLARRAY Memi[$1+7] # device supports cell array +define IDS_ZRES Memi[$1+8] # device resolution in Z +define IDS_FILLSTYLE Memi[$1+9] # number of fill styles +define IDS_ROAM Memi[$1+10] # device supports roam +define IDS_CANZM Memi[$1+11] # device supports zoom +define IDS_SELERASE Memi[$1+12] # device has selective erase +define IDS_FRAME Memi[$1+13] # pointer to frames area +define IDS_BITPL Memi[$1+14] # pointer to bitplane area + # extra space +define IDS_FRCOLOR Memi[$1+18] # frame color +define IDS_GRCOLOR Memi[$1+19] # graphics color +define IDS_LCURSOR Memi[$1+20] # last cursor accessed +define IDS_COLOR Memi[$1+21] # last color set +define IDS_TXSIZE Memi[$1+22] # last text size set +define IDS_TXFONT Memi[$1+23] # last text font set +define IDS_TYPE Memi[$1+24] # last line type set +define IDS_WIDTH Memi[$1+25] # last line width set +define IDS_DEVNAME Memi[$1+26] # name of open device +define IDS_CHARHEIGHT Memi[$1+30+$2-1] # character height +define IDS_CHARWIDTH Memi[$1+40+$2-1] # character width +define IDS_CHARSIZE Memr[P2R($1+50+$2-1)] # text sizes permitted +define IDS_PLAP ($1+60) # polyline attributes +define IDS_PMAP ($1+64) # polymarker attributes +define IDS_FAAP ($1+68) # fill area attributes +define IDS_TXAP ($1+71) # default text attributes + +# Substructure definitions. + +define LEN_PL 4 +define PL_STATE Memi[$1] # polyline attributes +define PL_LTYPE Memi[$1+1] +define PL_WIDTH Memi[$1+2] +define PL_COLOR Memi[$1+3] + +define LEN_PM 4 +define PM_STATE Memi[$1] # polymarker attributes +define PM_LTYPE Memi[$1+1] +define PM_WIDTH Memi[$1+2] +define PM_COLOR Memi[$1+3] + +define LEN_FA 3 # fill area attributes +define FA_STATE Memi[$1] +define FA_STYLE Memi[$1+1] +define FA_COLOR Memi[$1+2] + +define LEN_TX 10 # text attributes +define TX_STATE Memi[$1] +define TX_UP Memi[$1+1] +define TX_SIZE Memi[$1+2] +define TX_PATH Memi[$1+3] +define TX_SPACING Memr[P2R($1+4)] +define TX_HJUSTIFY Memi[$1+5] +define TX_VJUSTIFY Memi[$1+6] +define TX_FONT Memi[$1+7] +define TX_QUALITY Memi[$1+8] +define TX_COLOR Memi[$1+9] + +define IDS_EOD (-2) # flag for end of data + +define IDS_RESET 10 # escape 10 +define IDS_R_HARD 0 # hard reset +define IDS_R_MEDIUM 1 # medium +define IDS_R_SOFT 2 +define IDS_R_SNAPDONE 3 # end snap + +define IDS_SET_IP 11 # escape 11 +define IDS_SET_GP 12 # escape 12 +define IDS_DISPLAY_I 13 # escape 13 +define IDS_DISPLAY_G 14 # escape 14 +define IDS_SAVE 15 # escape 15 +define IDS_RESTORE 16 # escape 16 + +# max sizes + +define IDS_MAXIMPL 16 # maximum number of image planes +define IDS_MAXGRPL 16 # maximum number of graphics planes +define IDS_MAXBITPL 16 # maximum bit planes per frame +define IDS_MAXGCOLOR 8 # maximum number of colors (graphics) +define IDS_MAXDATA 8192 # maximum data structure in display + +define IDS_RED 1 +define IDS_GREEN 2 +define IDS_BLUE 3 +define IDS_YELLOW 4 +define IDS_RDBL 5 +define IDS_GRBL 6 +define IDS_WHITE 7 +define IDS_BLACK 8 + +define IDS_QUAD_UR 1 # upper right quad.: split screen mode +define IDS_QUAD_UL 2 +define IDS_QUAD_LL 3 +define IDS_QUAD_LR 4 + +define IDS_CONTROL 17 # escape 17 +define IDS_CTRL_LEN 6 +define IDS_CTRL_REG 1 # what to control +define IDS_CTRL_RW 2 # read/write field in control instr. +define IDS_CTRL_N 3 # count of DATA items +define IDS_CTRL_FRAME 4 # pertinent frame(s) +define IDS_CTRL_COLOR 5 # and color +define IDS_CTRL_OFFSET 6 # generalized "register" +define IDS_CTRL_DATA 7 # data array + +define IDS_WRITE 0 # write command +define IDS_READ 1 # read command +define IDS_READ_WT 2 # wait for action, then read +define IDS_OFF 1 # turn whatever off +define IDS_ON 2 +define IDS_CBLINK 3 # cursor blink +define IDS_CSHAPE 4 # cursor shape + +define IDS_CSTEADY 1 # cursor blink - steady (no blink) +define IDS_CFAST 2 # cursor blink - fast +define IDS_CMEDIUM 3 # cursor blink - medium +define IDS_CSLOW 4 # cursor blink - slow + +define IDS_FRAME_LUT 1 # look-up table for image frame +define IDS_GR_MAP 2 # graphics color map...lookup table per + # se makes little sense for bit plane +define IDS_INPUT_LUT 3 # global input lut +define IDS_OUTPUT_LUT 4 # final lut +define IDS_SPLIT 5 # split screen coordinates +define IDS_SCROLL 6 # scroll coordinates +define IDS_ZOOM 7 # zoom magnification +define IDS_OUT_OFFSET 8 # output bias +define IDS_MIN 9 # data minimum +define IDS_MAX 10 # data maximum +define IDS_RANGE 11 # output range select +define IDS_HISTOGRAM 12 # output data histogram +define IDS_ALU_FCN 13 # arithmetic feedback function +define IDS_FEEDBACK 14 # feedback control +define IDS_SLAVE 15 # auxillary host or slave processor + +define IDS_CURSOR 20 # cursor control - on/off/blink/shape +define IDS_TBALL 21 # trackball control - on/off +define IDS_DIGITIZER 22 # digitizer control - on/off +define IDS_BLINK 23 # for blink request +define IDS_SNAP 24 # snap function +define IDS_MATCH 25 # match lookup tables + +# snap codes ... just reuse color codes from above. +define IDS_SNAP_RED IDS_RED # snap the blue image +define IDS_SNAP_GREEN IDS_GREEN # green +define IDS_SNAP_BLUE IDS_BLUE # blue +define IDS_SNAP_RGB IDS_BLACK # rgb image --- do all three +define IDS_SNAP_MONO IDS_WHITE # do just one + +# cursor parameters + +define IDS_CSET 128 # number of cursors per "group" + +define IDS_CSPECIAL 4097 # special "cursors" + # must be > (IDS_CSET * number of cursor groups) +define IDS_CRAW IDS_CSPECIAL # raw cursor read +define IDS_BUT_RD 4098 # "cursor number" for read buttons cmd +define IDS_BUT_WT 4099 # wait for button press, then read +define IDS_CRAW2 4100 # A second "raw" cursor diff --git a/pkg/images/tv/iis/lumatch.cl b/pkg/images/tv/iis/lumatch.cl new file mode 100644 index 00000000..1890152b --- /dev/null +++ b/pkg/images/tv/iis/lumatch.cl @@ -0,0 +1,8 @@ +#{ LUMATCH -- Match the lookup tables for two frames. + +# frame,i,a,,1,4,frame to be adjusted +# ref_frame,i,a,,1,4,reference frame + +{ + _dcontrol (frame=frame, alternate=ref_frame, match=yes) +} diff --git a/pkg/images/tv/iis/lumatch.par b/pkg/images/tv/iis/lumatch.par new file mode 100644 index 00000000..60e3b7b3 --- /dev/null +++ b/pkg/images/tv/iis/lumatch.par @@ -0,0 +1,2 @@ +frame,i,a,,1,4,frame to be adjusted +ref_frame,i,a,,1,4,frame to be matched diff --git a/pkg/images/tv/iis/mkpkg b/pkg/images/tv/iis/mkpkg new file mode 100644 index 00000000..7b45b437 --- /dev/null +++ b/pkg/images/tv/iis/mkpkg @@ -0,0 +1,25 @@ +# Make the CV (Control Video) display load and control package. + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $update libpkg.a + $omake x_iis.x + $link x_iis.o libpkg.a -o xx_iis.e + ; + +install: + $move xx_iis.e bin$x_iis.e + ; + +libpkg.a: + @ids + @iism70 + @src + ; diff --git a/pkg/images/tv/iis/monochrome.cl b/pkg/images/tv/iis/monochrome.cl new file mode 100644 index 00000000..91de948f --- /dev/null +++ b/pkg/images/tv/iis/monochrome.cl @@ -0,0 +1,5 @@ +#{ MONOCHROME -- Set monochrome enhancement on display. + +{ + _dcontrol (map="mono") +} diff --git a/pkg/images/tv/iis/pseudocolor.cl b/pkg/images/tv/iis/pseudocolor.cl new file mode 100644 index 00000000..74d66a82 --- /dev/null +++ b/pkg/images/tv/iis/pseudocolor.cl @@ -0,0 +1,24 @@ +#{ PSEUDOCOLOR -- Select pseudocolor enhancement. + +# enhancement,s,a,linear,,,"type of pseudocolor enhancement:\n\ +# linear - map greyscale into a spectrum\n\ +# random - one randomly chosen color is assigned each greylevel\n\ +# 8color - eight random colors\n\ +# enter selection" +# window,b,h,yes,,,window display after enabling pseudocolor +# enhance,s,h + +{ + # Query for enchancement and copy into local param, otherwise each + # reference will cause a query. + enhance = enhancement + + if (enhance == "linear") + _dcontrol (map = "linear", window=window) + else if (enhance == "random") + _dcontrol (map = "random", window=window) + else if (enhance == "8color") + _dcontrol (map = "8color", window=window) + else + error (0, "unknown enhancement") +} diff --git a/pkg/images/tv/iis/pseudocolor.par b/pkg/images/tv/iis/pseudocolor.par new file mode 100644 index 00000000..e99d8d80 --- /dev/null +++ b/pkg/images/tv/iis/pseudocolor.par @@ -0,0 +1,7 @@ +enhancement,s,a,random,,,"type of pseudocolor enhancement:\n\ + linear - map greyscale into a spectrum\n\ + random - a randomly chosen color is assigned to each greylevel\n\ + 8color - use eight colors chosen at random\n\ +enter selection" +window,b,h,yes,,,window display after enabling pseudocolor +enhance,s,h diff --git a/pkg/images/tv/iis/rgb.cl b/pkg/images/tv/iis/rgb.cl new file mode 100644 index 00000000..4fada018 --- /dev/null +++ b/pkg/images/tv/iis/rgb.cl @@ -0,0 +1,11 @@ +#{ RGB -- Select rgb display mode. + +# red_frame,i,a,1,1,4,red frame +# green_frame,i,a,2,1,4,green frame +# blue_frame,i,a,3,1,4,blue frame +# window,b,h,no,,,window RGB frames + +{ + _dcontrol (type="rgb", red_frame=red_frame, green_frame=green_frame, + blue_frame=blue_frame, rgb_window=window) +} diff --git a/pkg/images/tv/iis/rgb.par b/pkg/images/tv/iis/rgb.par new file mode 100644 index 00000000..86d11871 --- /dev/null +++ b/pkg/images/tv/iis/rgb.par @@ -0,0 +1,4 @@ +red_frame,i,a,1,1,4,red frame +green_frame,i,a,2,1,4,green frame +blue_frame,i,a,3,1,4,blue frame +window,b,h,no,,,window RGB frames diff --git a/pkg/images/tv/iis/src/blink.x b/pkg/images/tv/iis/src/blink.x new file mode 100644 index 00000000..fc176f7a --- /dev/null +++ b/pkg/images/tv/iis/src/blink.x @@ -0,0 +1,132 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# BLINK -- blink the display. + +procedure blink() + +char token[SZ_LINE] +int tok, count, rate +int sets, button, i +int ctoi(), ip +pointer sp, setp, ptr +int cv_rdbut() +int val, nchar + +define errmsg 10 + +include "cv.com" + +begin + # get rate for blink + + call gargtok (tok, token, SZ_LINE) + if (tok != TOK_NUMBER) { + call eprintf ("Bad blink rate: %s\n") + call pargstr (token) + return + } + ip = 1 + count = ctoi(token, ip, rate) + if (rate < 0) { + call eprintf ("negative rate not legal\n") + return + } + + call smark (sp) + # The "3" is to hold frame/color/quad for one frame; + # the "2" is to allow duplication of each frame so that + # some frames can stay "on" longer. The extra "1" is for graphics. + call salloc (setp, 2 * 3 * (cv_maxframes+1), TY_POINTER) + sets = 0 + + # which frames to blink + + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + while ( (sets <= cv_maxframes+1) && (tok != TOK_NEWLINE) ) { + sets = sets + 1 + ptr = setp + (3 * (sets-1)) + call salloc (Memi[ptr], IDS_MAXIMPL+1, TY_SHORT) + if (tok == TOK_IDENTIFIER) { + if (token[1] == 'f') { + call cv_frame (token[2], Mems[Memi[ptr]]) + if (Mems[Memi[ptr]] == ERR) { + call sfree (sp) + return + } + } + } else if (tok == TOK_NUMBER) { + ip = 1 + nchar = ctoi (token[1], ip, val) + if ( (val < 0) || (val > cv_maxframes)) { + call eprintf ("illegal frame value: %s\n") + call pargstr (token) + call sfree (sp) + return + } + Mems[Memi[ptr]] = val + Mems[Memi[ptr]+1] = IDS_EOD + } else { +errmsg + call eprintf ("Unexpected input: %s\n") + call pargstr (token) + call sfree (sp) + return + } + ptr = ptr + 1 + call salloc (Memi[ptr], IDS_MAXGCOLOR+1, TY_SHORT) + call salloc (Memi[ptr+1], 5, TY_SHORT) + Mems[Memi[ptr]] = IDS_EOD # default all colors + Mems[Memi[ptr+1]] = IDS_EOD # default all quads + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if ( (tok != TOK_IDENTIFIER) && (tok != TOK_NEWLINE)) + goto errmsg + if ((tok == TOK_IDENTIFIER) && (token[1] == 'c')) { + call cv_color (token[2], Mems[Memi[ptr]]) + if (Mems[Memi[ptr]] == ERR) { + call sfree (sp) + return + } + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + if ( (tok != TOK_IDENTIFIER) && (tok != TOK_NEWLINE)) + goto errmsg + if ((tok == TOK_IDENTIFIER) && (token[1] == 'q')) { + call cv_quad (token[2], Mems[Memi[ptr+1]]) + if (Mems[Memi[ptr+1]] == ERR) { + call sfree (sp) + return + } + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + } # end while + + button = cv_rdbut() # clear any buttons pressed + call eprintf ("Press any button to terminate blink\n") + repeat { + do i = 1, sets { + ptr = setp + 3 * (i-1) + call cvdisplay (IDS_ON, IDS_DISPLAY_I, Mems[Memi[ptr]], + Mems[Memi[ptr+1]], Mems[Memi[ptr+2]]) + # Delay for "rate*100" milliseconds + call zwmsec (rate * 100) + + # Leave something on screen when button pushed + button = cv_rdbut() + if (button > 0) + break + call cvdisplay (IDS_OFF, IDS_DISPLAY_I, Mems[Memi[ptr]], + Mems[Memi[ptr+1]], Mems[Memi[ptr+2]]) + } + } until (button > 0) + + call sfree (sp) +end diff --git a/pkg/images/tv/iis/src/clear.x b/pkg/images/tv/iis/src/clear.x new file mode 100644 index 00000000..60cf69eb --- /dev/null +++ b/pkg/images/tv/iis/src/clear.x @@ -0,0 +1,48 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# CLEAR -- clear certain frames in the display + +procedure clear() + +char token[SZ_LINE] +int tok +short frames[IDS_MAXIMPL+1] + +define nexttok 10 + +include "cv.com" + +begin + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + + while ( (tok == TOK_IDENTIFIER) || (tok == TOK_NUMBER) ) { + if (tok == TOK_IDENTIFIER) { + switch (token[1]) { + case 'a', 'g': + # all colors + call cvclearg (short(IDS_EOD), short (IDS_EOD)) + if (token[1] == 'g') + goto nexttok + frames[1] = IDS_EOD + + case 'f': + call cv_frame (token[2], frames) + } + } else + call cv_frame (token[1], frames) + + call cvcleari (frames) + if (token[1] == 'a') + return + + # get next token +nexttok + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } +end diff --git a/pkg/images/tv/iis/src/cv.com b/pkg/images/tv/iis/src/cv.com new file mode 100644 index 00000000..ec9c70e7 --- /dev/null +++ b/pkg/images/tv/iis/src/cv.com @@ -0,0 +1,16 @@ +# common block for cv + +pointer cv_gp # file descriptor to write +pointer cv_stack # working space for escape sequences +int cv_maxframes # device max frames +int cv_maxgraph # device max graph planes +int cv_xcen, cv_ycen # user pixel coords of center of dev. +int cv_xres, cv_yres # device resolution +int cv_zres # device z resolution +real cv_xcon, cv_ycon # conversion from NDC to GKI +int cv_grch # graphics channel +real cv_xwinc, cv_ywinc # cursor position for window command + +common /cvcom/ cv_gp, cv_stack, cv_maxframes, cv_maxgraph, cv_xcen, cv_ycen, + cv_xres, cv_yres, cv_zres, cv_xcon, cv_ycon, cv_grch, + cv_xwinc, cv_ywinc diff --git a/pkg/images/tv/iis/src/cv.h b/pkg/images/tv/iis/src/cv.h new file mode 100644 index 00000000..80f3016b --- /dev/null +++ b/pkg/images/tv/iis/src/cv.h @@ -0,0 +1,51 @@ +# constants for cv package...should come from a graphcap entry + +# These are one based. +define CV_XCEN 257 +define CV_YCEN 256 + +define CV_XRES 512 +define CV_YRES 512 +define CV_ZRES 256 + +define CV_MAXF 4 +define CV_MAXG 7 + +define CV_GRCHNUM 16 + +# CVLEN is just the *estimated* never to be exceeded amount of storage needed +# to set up the escape sequence. It could be determined dynamically by +# changing cv_move to count elements instead of moving them. Then the known +# counts would be used with amovs to hustle the elements into the "salloc'ed" +# space. Instead, with a static count, we can salloc once upon entering +# the cv program and free up at exit. + +define CVLEN 128 + +# Following are from "display.h"... only SAMPLE_SIZE and MAXLOG needed +# as of May, 1985. But we might incorporate other programs from "tv", +# so leave them. + +# Size limiting parameters. + +define MAXCHAN 2 +define SAMPLE_SIZE 600 + +# If a logarithmic greyscale transformation is desired, the input range Z1:Z2 +# will be mapped into the range 1.0 to 10.0 ** MAXLOG before taking the log +# to the base 10. + +define MAXLOG 3 + +# The following parameter is used to compare display pixel coordinates for +# equality. It determines the maximum permissible magnification. The machine +# epsilon is not used because the computations are nontrivial and accumulation +# of error is a problem. + +define DS_TOL (1E-4) + +# These parameters are needed for user defined transfer functions. + +define SZ_BUF 4096 +define STARTPT 0.0E0 +define ENDPT 4095.0E0 diff --git a/pkg/images/tv/iis/src/cv.x b/pkg/images/tv/iis/src/cv.x new file mode 100644 index 00000000..a169a402 --- /dev/null +++ b/pkg/images/tv/iis/src/cv.x @@ -0,0 +1,175 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" +include +include +include +include "cv.h" + +# Captain Video + +procedure t_cv() + +pointer gp +char device[SZ_FNAME] +char command[SZ_LINE] + +pointer gopen(), sp +int dd[LEN_GKIDD] + +int scan, tok, envgets() + +include "cv.com" + +begin + call smark (sp) + call salloc (cv_stack, CVLEN, TY_SHORT) + + if (envgets ("stdimage", device, SZ_FNAME) == 0) + call error (EA_FATAL, + "variable 'stdimage' not defined in environment") + + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, READ_WRITE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + # to do: + # initialize local variables: image display size, etc + # instead of defines such as MCXSCALE, etc + cv_maxframes = CV_MAXF + cv_maxgraph = CV_MAXG + cv_xcen = CV_XCEN + cv_ycen = CV_YCEN + cv_xres = CV_XRES + cv_yres = CV_YRES + cv_zres = CV_ZRES + cv_gp = gp + cv_xcon = real(GKI_MAXNDC+1)/CV_XRES + cv_ycon = real(GKI_MAXNDC+1)/CV_YRES + cv_grch = CV_GRCHNUM + cv_xwinc = -1. # Flag: Don't know what lut is + + repeat { + call printf (":-) ") + call flush (STDOUT) + if (scan() == EOF) + break + call gargtok(tok, command, SZ_LINE) + if ((tok == TOK_EOS) || (tok == TOK_NEWLINE)) + next + # decode next command + call strlwr(command) + switch (command[1]) { + case 'x', 'q': + break + + + case 'b': + call blink + + case 'c': + if (command[2] == 'l') + call clear + else + call rdcur + + case 'd': + call display(command[2]) + + case 'e': # erase means clear + call clear + + case 'h', '?': + call help + + # case 'l': + # call load + + case 'm': + call match + + case 'o': + call offset + + case 'p': + if ( command[2] == 's') + call map(command[2]) # pseudo color + else + call pan + + case 'r': + if (command[2] == 'e') + call reset + else + call range + + case 's': + if (command[2] == 'n') + call snap + else + call split + + case 't': + call tell + + case 'w': + if (command[2] == 'r') + call text + else + call window + + case 'z': + call zoom + + default: + call eprintf("unknown command: %s\n") + call pargstr(command[1]) + + } # end switch statement + + } # end repeat statment + + # all done + + call gclose ( gp ) + call ids_close + call sfree (sp) +end + + +# HELP -- print informative message + +procedure help() + +begin + call eprintf ("--- () : optional; [] : select one; N : number; C/F/Q : see below\n") + call eprintf ("b(link) N F (C Q) (F (C Q)..) blink N = 10 is one second\n") + call eprintf ("c(ursor) [on off F] cursor\n") + call eprintf ("di F (C Q) [on off] display image\n") + call eprintf ("dg C (F Q) [on off] display graphics\n") + call eprintf ("e(rase) [N a(ll) g(raphics) F] erase (clear)\n") + #call eprintf ("l(oad) load a frame\n") + call eprintf ("m(atch) (o) F (C) (to) (F) (C) match (output) lookup table\n") + call eprintf ("o(ffset) C N offset color N: 0 to +- 4095\n") + call eprintf ("p(an) (F) pan images\n") + call eprintf ("ps(eudo) (o) (F C) (rn sn) pseudo color mapping rn/sn: random n/seed n\n") + call eprintf ("r(ange) N (C) (N C ...) scale image N: 1-8\n") + call eprintf ("re(set) [r i t a] reset display registers/image/tables/all\n") + call eprintf ("sn(ap) (C) snap a picture\n") + call eprintf ("s(plit) [c o px,y nx,y] split picture\n") + call eprintf ("t(ell) tell display state\n") + call eprintf ("w(indow) (o) (F C) window (output) frames\n") + call eprintf ("wr(ite) [F C] text write text to frame/graphics\n") + call eprintf ("z(oom) N (F) zoom frames N: 1-8\n") + call eprintf ("x or q exit/quit\n") + call eprintf ("--- C: letter c followed by r/g/b/a or, for snap r,g,b,m,bw,rgb,\n") + call eprintf ("--- or for dg r/g/b/y/p/m/w, as 'cr', 'ca', or 'cgb'\n") + call eprintf ("--- F: f followed by a frame number or 'a' for all\n") + call eprintf ("--- Q: q followed by quadrant number or t,b,l,r for top, bottom,...\n") +end diff --git a/pkg/images/tv/iis/src/cvparse.x b/pkg/images/tv/iis/src/cvparse.x new file mode 100644 index 00000000..46aba66b --- /dev/null +++ b/pkg/images/tv/iis/src/cvparse.x @@ -0,0 +1,196 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../lib/ids.h" +include + +# CVPARSE -- parsing routines for the cv package + +# CV_FRAME -- parse a frame specification + +procedure cv_frame(str, result) + +char str[ARB] # input string +short result[ARB] # result string + +int ip +int op +int i +int used[IDS_MAXIMPL] +int gused + +include "cv.com" + +begin + if (str[1] == 'a') { + result[1] = IDS_EOD + return + } + call aclrs(used,IDS_MAXIMPL) + gused = 0 + op = 1 + for (ip = 1; str[ip] != EOS; ip = ip + 1) { + if (!IS_DIGIT(str[ip])) { + if (str[ip] == 'g') + gused = 1 + else { + call eprintf("unknown frame specifier: %c\n") + call pargc(str[ip]) + } + next + } + i = TO_INTEG (str[ip]) # fail if > than 9 planes! use ctoi() + if ((i < 1) || (i > cv_maxframes) ) { + call eprintf ("out of bounds frame: %d\n") + call pargi(i) + next + } else + used[i] = 1 + } + do i= 1,IDS_MAXIMPL + if (used[i] != 0) { + result[op] = i + op = op + 1 + } + if (gused != 0) { + result[op] = cv_grch + op = op + 1 + } + if (op > 1) + result[op] = IDS_EOD + else + result[op] = ERR +end + + +# CV_COLOR -- parse a color specification + +procedure cv_color(str, result) + +char str[ARB] # input string +short result[ARB] # result string + +int ip +int op +int i +short val +short used[IDS_MAXGCOLOR+1] + +include "cv.com" + +begin + if (str[1] == 'a') { + result[1] = IDS_EOD + return + } + call aclrs (used, IDS_MAXGCOLOR+1) + op = 1 + for (ip = 1; str[ip] != EOS; ip = ip + 1) { + switch (str[ip]) { + case 'r': + val = IDS_RED + + case 'g': + val = IDS_GREEN + + case 'b': + val = IDS_BLUE + + case 'y': + val = IDS_YELLOW + + case 'w': + val = IDS_WHITE + + case 'p': + val = IDS_RDBL + + case 'm': + val = IDS_GRBL + + default: + call eprintf("unknown color: %c\n") + call pargc(str[ip]) + next + } + used[val] = 1 + } + do i = 1, IDS_MAXGCOLOR+1 + if (used[i] != 0) { + result[op] = i + op = op + 1 + } + if (op > 1) + result[op] = IDS_EOD + else + result[op] = ERR +end + + +# CV_QUAD -- parse a quad specification + +procedure cv_quad(str, result) + +char str[ARB] # input string +short result[ARB] # result string + +int ip +int op +int i +short used[4] + +include "cv.com" + +begin + if (str[1] == 'a') { + result[1] = IDS_EOD + return + } + call aclrs(used, 4) + op = 1 + for (ip = 1; str[ip] != EOS; ip = ip + 1) { + if (!IS_DIGIT(str[ip])) { + switch(str[ip]) { + case 'a': + call amovks (1, used, 4) + + case 't': + used[1] = 1 + used[2] = 1 + + case 'b': + used[3] = 1 + used[4] = 1 + + case 'l': + used[2] = 1 + used[3] = 1 + + case 'r': + used[1] = 1 + used[4] = 1 + + default: + call eprintf("unknown quad specifier: %c\n") + call pargc(str[ip]) + } + } else { + i = TO_INTEG (str[ip]) + if ((i < 1) || (i > 4)) { + call eprintf ("out of bounds quad: %d\n") + call pargi(i) + next + } else + used[i] = 1 + } + } + do i = 1,4 { + if (used[i] != 0) { + result[op] = i + op = op + 1 + } + } + if (op > 1) + result[op] = IDS_EOD + else + result[op] = ERR +end diff --git a/pkg/images/tv/iis/src/cvulut.x b/pkg/images/tv/iis/src/cvulut.x new file mode 100644 index 00000000..683c9500 --- /dev/null +++ b/pkg/images/tv/iis/src/cvulut.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "cv.h" + +# CV_ULUT -- Generates a look up table from data supplied by user. The +# data is read from a two column text file of intensity, greyscale values. +# The input data are sorted, then mapped to the x range [0-4096]. A +# piecewise linear look up table of 4096 values is then constructed from +# the (x,y) pairs given. A pointer to the look up table, as well as the z1 +# and z2 intensity endpoints, is returned. + +procedure cv_ulut (fname, z1, z2, lut) + +char fname[SZ_FNAME] # Name of file with intensity, greyscale values +real z1 # Intensity mapped to minimum gs value +real z2 # Intensity mapped to maximum gs value +pointer lut # Look up table - pointer is returned + +pointer sp, x, y +int nvalues, i, j, x1, x2, y1 +real delta_gs, delta_xv, slope +errchk cv_rlut, cv_sort, malloc + +begin + call smark (sp) + call salloc (x, SZ_BUF, TY_REAL) + call salloc (y, SZ_BUF, TY_REAL) + + # Read intensities and greyscales from the user's input file. The + # intensity range is then mapped into a standard range and the + # values sorted. + + call cv_rlut (fname, Memr[x], Memr[y], nvalues) + call alimr (Memr[x], nvalues, z1, z2) + call amapr (Memr[x], Memr[x], nvalues, z1, z2, STARTPT, ENDPT) + call cv_sort (Memr[x], Memr[y], nvalues) + + # Fill lut in straight line segments - piecewise linear + call malloc (lut, SZ_BUF, TY_SHORT) + do i = 1, nvalues-1 { + delta_gs = Memr[y+i] - Memr[y+i-1] + delta_xv = Memr[x+i] - Memr[x+i-1] + slope = delta_gs / delta_xv + x1 = int (Memr[x+i-1]) + x2 = int (Memr[x+i]) + y1 = int (Memr[y+i-1]) + do j = x1, x2-1 + Mems[lut+j-1] = y1 + slope * (j-x1) + } + + call sfree (sp) +end + + +# CV_RLUT -- Read text file of x, y, values. + +procedure cv_rlut (utab, x, y, nvalues) + +char utab[SZ_FNAME] # Name of list file +real x[SZ_BUF] # Array of x values, filled on return +real y[SZ_BUF] # Array of y values, filled on return +int nvalues # Number of values in x, y vectors - returned + +int n, fd +pointer sp, lbuf, ip +real xval, yval +int getline(), open() +errchk open, sscan, getline, malloc + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + iferr (fd = open (utab, READ_ONLY, TEXT_FILE)) + call error (0, "Error opening user table") + + n = 0 + + while (getline (fd, Memc[lbuf]) != EOF) { + # Skip comment lines and blank lines. + if (Memc[lbuf] == '#') + next + for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '\n' || Memc[ip] == EOS) + next + + # Decode the points to be plotted. + call sscan (Memc[ip]) + call gargr (xval) + call gargr (yval) + + n = n + 1 + if (n > SZ_BUF) + call error (0, + "Intensity transformation table cannot exceed 4096 values") + + x[n] = xval + y[n] = yval + } + + nvalues = n + call close (fd) + call sfree (sp) +end + + +# CV_SORT -- Bubble sort of paired arrays. + +procedure cv_sort (xvals, yvals, nvals) + +real xvals[nvals] # Array of x values +real yvals[nvals] # Array of y values +int nvals # Number of values in each array + +int i, j +real temp +define swap {temp=$1;$1=$2;$2=temp} + +begin + for (i = nvals; i > 1; i = i - 1) + for (j = 1; j < i; j = j + 1) + if (xvals[j] > xvals[j+1]) { + # Out of order; exchange y values + swap (xvals[j], xvals[j+1]) + swap (yvals[j], yvals[j+1]) + } +end diff --git a/pkg/images/tv/iis/src/cvutil.x b/pkg/images/tv/iis/src/cvutil.x new file mode 100644 index 00000000..81721081 --- /dev/null +++ b/pkg/images/tv/iis/src/cvutil.x @@ -0,0 +1,538 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "cv.h" +include "../lib/ids.h" + +# CVUTIL -- utility control routines for cv package + +############ CLEAR display ############ +# CVCLEARG -- clear all of graphics (bit) planes + +procedure cvclearg (frame, color) + +short frame[ARB] +short color[ARB] + +int count +int cv_move() + +include "cv.com" + +begin + count = cv_move (frame, Mems[cv_stack]) + count = count + cv_move (color, Mems[cv_stack+count]) + call gescape (cv_gp, IDS_SET_GP, Mems[cv_stack], count) + call gclear (cv_gp) +end + +# CVCLEARI -- clear specified image frames + +procedure cvcleari (frames) + +short frames[ARB] + +include "cv.com" + +begin + call cv_iset (frames) + call gclear (cv_gp) +end + +############ CURSOR and BUTTON ############ +# CV_RDBUT -- read button on trackball (or whatever) +# if none pressed, will get zero back + +int procedure cv_rdbut() + +int oldcnum +real x, y +int button +int gstati + +include "cv.com" + +begin + oldcnum = gstati (cv_gp, G_CURSOR) + call gseti (cv_gp, G_CURSOR, IDS_BUT_RD) + call ggcur (cv_gp, x, y, button) + call gseti (cv_gp, G_CURSOR, oldcnum) + return(button) +end + +# CV_WTBUT -- wait for button to be pressed, then read it + +int procedure cv_wtbut() + +int oldcnum +real x, y +int button +int gstati + +include "cv.com" + +begin + oldcnum = gstati (cv_gp, G_CURSOR) + call gseti (cv_gp, G_CURSOR, IDS_BUT_WT) + call ggcur (cv_gp, x, y, button) + call gseti (cv_gp, G_CURSOR, oldcnum) + return(button) +end + +# CV_RCUR -- read cursor. The cursor read/set routines do not restore +# the cursor number...this to avoid numerous stati/seti calls that +# usually are not needed. + +procedure cv_rcur (cnum, x, y) + +int cnum +real x,y +int junk + +include "cv.com" + +begin + call gseti (cv_gp, G_CURSOR, cnum) + call ggcur (cv_gp, x, y, junk) +end + +# CV_SCUR -- set cursor + +procedure cv_scur (cnum, x, y) + +int cnum +real x,y + +include "cv.com" + +begin + call gseti (cv_gp, G_CURSOR, cnum) + call gscur (cv_gp, x, y) +end + + +# CV_RCRAW -- read the raw cursor (return actual screen coordinates). + +procedure cv_rcraw (x, y) + +real x,y + +include "cv.com" + +begin + call cv_rcur (IDS_CRAW, x, y) +end + +# CV_SCRAW -- set raw cursor + +procedure cv_scraw (x, y) + +real x,y + +include "cv.com" + +begin + call cv_scur (IDS_CRAW, x, y) +end + + +# cvcur -- turn cursor on or off + +procedure cvcur (instruction) + +int instruction + +include "cv.com" + +begin + Mems[cv_stack] = IDS_CURSOR + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = 1 + Mems[cv_stack+3] = IDS_EOD + Mems[cv_stack+4] = IDS_EOD + Mems[cv_stack+5] = 1 + Mems[cv_stack+6] = instruction + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], 7) +end + +############ DISPLAY ############ +# cvdisplay + +procedure cvdisplay (instruction, device, frame, color, quad) + +int instruction +int device +short frame, color, quad + +int i +int cv_move() + +include "cv.com" + +begin + Mems[cv_stack] = instruction + i = cv_move (frame, Mems[cv_stack+1]) + i = i + cv_move (color, Mems[cv_stack+1+i]) + i = i + cv_move (quad, Mems[cv_stack+1+i]) + call gescape (cv_gp, device, Mems[cv_stack], 1+i) +end + +############ MATCH ############ +# cvmatch -- build match escape sequence + +procedure cvmatch (lt, fr, cr, frames, color) + +int lt # type +short fr[ARB] # reference frame and color +short cr[ARB] +short frames[ARB] # frames to be changed +short color[ARB] # and colors + +int count, n +int cv_move() + +include "cv.com" + +begin + Mems[cv_stack] = IDS_MATCH + Mems[cv_stack+1] = lt + count = cv_move (fr, Mems[cv_stack+3]) + count = count + cv_move (cr, Mems[cv_stack+3+count]) + n = count + Mems[cv_stack+count+3] = 0 # unused offset + count = count + cv_move (frames, Mems[cv_stack+4+count]) + count = count + cv_move (color, Mems[cv_stack+4+count]) + Mems[cv_stack+2] = count - n + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], count+4) +end + +############ OFFSET ############ +# cvoffset -- set offset registers + +procedure cvoffset( color, data) + +short color[ARB] +short data[ARB] + +int count, cv_move() +int i + +include "cv.com" + +begin + Mems[cv_stack] = IDS_OUT_OFFSET + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+3] = IDS_EOD # no-op the frames slot + count = cv_move (color, Mems[cv_stack+4]) + Mems[cv_stack+4+count] = 1 # (unused) offset + i = cv_move (data, Mems[cv_stack+5+count]) + i = i - 1 # don't include EOD of "data" + Mems[cv_stack+2] = i + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], i+count+5) +end + +############ PAN ############ +# cvpan -- move the image(s) around +# The x,y coordinates are NDC that, it is assumed, came from a cursor +# read, and therefore are of the form +# ((one_based_pixel-1)/(resolution)) *(GKI_MAXNDC+1) / GKI_MAXNDC +# The division by GKI_MAXNDC turns into NDC what was GKI ranging from +# 0 through 511*64 (for IIS) which conforms to the notion of specifying +# each pixel by its left/bottom GKI boundary. + +procedure cvpan (frames, x, y) + +short frames[ARB] +real x,y # position in NDC + +int count, cv_move() + +include "cv.com" + +begin + Mems[cv_stack] = IDS_SCROLL + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = 3 + count = cv_move (frames, Mems[cv_stack+3]) + Mems[cv_stack+3+count] = IDS_EOD # all colors + Mems[cv_stack+4+count] = 1 # (unused) offset + Mems[cv_stack+5+count] = x * GKI_MAXNDC + Mems[cv_stack+6+count] = y * GKI_MAXNDC + Mems[cv_stack+7+count] = IDS_EOD # for all frames + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], count+8) +end + +############ RANGE ############ +# cvrange -- scale ouput before final look up table + +procedure cvrange ( color, range) + +short color[ARB] +short range[ARB] + +int cv_move(), count, i + +include "cv.com" + +begin + Mems[cv_stack] = IDS_RANGE + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+3] = IDS_EOD # all frames + count = cv_move (color, Mems[cv_stack+4]) + Mems[cv_stack+4+count] = 1 # (unused) offset + i = cv_move (range, Mems[cv_stack+5+count]) + i = i - 1 # don't include EOD of "range" + Mems[cv_stack+2] = i + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], i+count+5) +end + +############ RESET display ############ +# cvreset -- reset display +# SOFT -- everything but lookup tables and image/graphics planes +# MEDIUM -- everything but image/graphics planes +# HARD -- everything...planes are cleared, all images OFF + +procedure cvreset (hardness) + +int hardness + +include "cv.com" + +begin + Mems[cv_stack] = hardness + call gescape (cv_gp, IDS_RESET, Mems[cv_stack], 1) +end + + +############ SNAP a picture ############ +# cvsnap -- takes a full picture of image display + +procedure cvsnap (fname, snap_color) + +char fname[ARB] # image file name +int snap_color + +pointer im, immap(), impl2s() +int i, factor +real y + +include "cv.com" + +begin + im = immap(fname, NEW_FILE, 0) + IM_PIXTYPE(im) = TY_SHORT + IM_LEN(im,1) = cv_xres + IM_LEN(im,2) = cv_yres + + Mems[cv_stack] = IDS_SNAP + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = 1 # frame, color are not relevant + Mems[cv_stack+3] = IDS_EOD + Mems[cv_stack+4] = IDS_EOD + Mems[cv_stack+5] = 0 + Mems[cv_stack+6] = snap_color + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], 7) + + factor = cv_yres/10 + 1 + call eprintf (" (%% done: ") + call flush (STDERR) + do i = 0, cv_yres-1 { + if ( mod(i,factor) == 0) { + call eprintf ("%d ") + call pargi (int(10*i/cv_yres)*10) + call flush (STDERR) + } + y = real(i)*cv_ycon / GKI_MAXNDC. + call ggcell (cv_gp, Mems[impl2s(im,i+1)], cv_xres, 1, 0.0, + y, 1.0, y) + } + call eprintf ("100)\n") + + call imunmap(im) + Mems[cv_stack] = IDS_R_SNAPDONE + call gescape (cv_gp, IDS_RESET, Mems[cv_stack], 1) +end + +############ SPLIT ############ +# cvsplit -- set split screen position + +procedure cvsplit (x, y) + +real x,y # NDC coordinates + +include "cv.com" + +begin + Mems[cv_stack] = IDS_SPLIT + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = 2 + Mems[cv_stack+3] = IDS_EOD # no-op frame and color + Mems[cv_stack+4] = IDS_EOD + Mems[cv_stack+5] = 1 # (unused) offset + # NOTE multiplacation by MAXNDC+1 ... x, and y, are never == 1.0 + # ( see split.x) + # and truncation effects will work out just right, given what the + # image display kernel does with these numbers + Mems[cv_stack+6] = x * (GKI_MAXNDC+1) + Mems[cv_stack+7] = y * (GKI_MAXNDC+1) + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], 8) +end + +############ TEXT ############ +# Write text + +procedure cvtext (x, y, text, size) + +real x, y, size +char text[ARB] + +char format[SZ_LINE] + +include "cv.com" + +begin + call sprintf (format, SZ_LINE, "s=%f") + call pargr (size) + call gtext (cv_gp, x, y, text, format) +end + +############ WHICH ############ +# Tell which frames are one. The best we can do now is +# tell if any, and if so, which is the "first" + +procedure cvwhich (fr) + +short fr[ARB] + +real x,y +int cnum, oldcnum +int gstati + +include "cv.com" + +begin + # Use here the fact that if cursor number is zero, the + # kernel will return the number of the first displayed + # frame, or "ERR" if none. + oldcnum = gstati (cv_gp, G_CURSOR) + cnum = 0 + call gseti (cv_gp, G_CURSOR, cnum) + call ggcur (cv_gp, x, y, cnum) + call gseti (cv_gp, G_CURSOR, oldcnum) + fr[1] = cnum + fr[2] = IDS_EOD +end + +############ WLUT ############ +# cvwlut ... change lookup tables +# the data is in form of line endpoints. + +procedure cvwlut (device, frames, color, data, n) + +int device +short frames[ARB] +short color[ARB] +short data[ARB] +int n + +int count, cv_move() + +include "cv.com" + +begin + # Device had better refer to a look-up table, or who knows + # what will happen! + Mems[cv_stack] = device + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = n + count = cv_move (frames, Mems[cv_stack+3]) + count = count + cv_move (color, Mems[cv_stack+3+count]) + Mems[cv_stack+3+count] = 1 # (unused) offset + call amovs (data, Mems[cv_stack+count+4],n) + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], n+count+4) +end + +############ ZOOM ############ +# cvzoom -- zoom the image +# See comment under PAN about x and y. + +procedure cvzoom (frames, power, x, y) + +short frames[ARB] +int power +real x,y + +int count, cv_move() + +include "cv.com" + +begin + Mems[cv_stack] = IDS_ZOOM + Mems[cv_stack+1] = IDS_WRITE + Mems[cv_stack+2] = 3 + count = cv_move (frames, Mems[cv_stack+3]) + Mems[cv_stack+3+count] = IDS_EOD # (unused) color + Mems[cv_stack+4+count] = IDS_EOD # (unused) offset + Mems[cv_stack+5+count] = power + Mems[cv_stack+6+count] = x * GKI_MAXNDC + Mems[cv_stack+7+count] = y * GKI_MAXNDC + call gescape (cv_gp, IDS_CONTROL, Mems[cv_stack], count+8) +end + +############ SUBROUTINES ############## +# CV_MOVE -- transfer an array into the escape data array; returns number +# of items transfered. + +int procedure cv_move (in, out) + +short in[ARB] +short out[ARB] + +int count + +begin + count = 0 + repeat { + count = count + 1 + out[count] = in[count] + } until (in[count] == IDS_EOD) + return (count) +end + +# CV_ISET -- Tell the image kernel that i/o is to be done for the +# specified frame/frames. + +procedure cv_iset (frames) + +short frames[ARB] + +short idata[30] +int i, cv_move() + +include "cv.com" + +begin + i = cv_move (frames, idata) + idata[i+1] = IDS_EOD # all bit planes + call gescape (cv_gp, IDS_SET_IP, idata, i+1) +end + +# CV_GSET -- Tell the image kernel that i/o is to be done for the +# specified colors. + +procedure cv_gset (colors) + +short colors[ARB] + +short idata[30] +int i, cv_move() + +include "cv.com" + +begin + idata[1] = IDS_EOD # all "frames" + i = cv_move (colors, idata[2]) + call gescape (cv_gp, IDS_SET_GP, idata, i+1) +end diff --git a/pkg/images/tv/iis/src/display.x b/pkg/images/tv/iis/src/display.x new file mode 100644 index 00000000..d04b1365 --- /dev/null +++ b/pkg/images/tv/iis/src/display.x @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# DISPLAY -- Turn frames on or off + +procedure display(command) + +char command[ARB] + +int tok +char token[SZ_LINE] +short color[IDS_MAXGCOLOR+1] +short frames[IDS_MAXIMPL+1] +short quad[5] +short instruction +int escape +include "cv.com" + +begin + if (command[1] == 'i') + escape = IDS_DISPLAY_I + else if (command[1] == 'g') + escape = IDS_DISPLAY_G + else { + call eprintf ("Only 'di' or 'dg' are understood\n") + return + } + + instruction = ERR + frames[1] = ERR + color[1] = ERR + quad[1] = IDS_EOD + + repeat { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if ( tok == TOK_IDENTIFIER) { + switch (token[1]) { + case 'c': + call cv_color (token[2], color) + if (color[1] == ERR) + return + + case 'f': + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + + + case 'o': + if (token[2] == 'n') + instruction = IDS_ON + else if (token[2] == 'f') + instruction = IDS_OFF + + case 'q': + call cv_quad (token[2], quad) + if (quad[1] == ERR) + return + } + } else if (tok == TOK_NUMBER) { + call cv_frame (token[1], frames) + if (frames[1] == ERR) + return + } + } until ( tok == TOK_NEWLINE ) + + + # Require a frame number, but allow default of color and quad to "all". + # But, for graphics, default the frame and require a color. + # In either case, for OFF, allow all defaults. + if (escape == IDS_DISPLAY_I) { + if ((instruction == IDS_OFF) && (frames[1] == ERR)) + frames[1] = IDS_EOD + if ( color[1] == ERR) + color[1] = IDS_EOD + } else { + if ((instruction == IDS_OFF) && ( color[1] == ERR) ) + color[1] = IDS_EOD + if ( frames[1] == ERR) + frames[1] = IDS_EOD + } + + if (frames[1] == ERR) { + call eprintf ("Frame specification required\n") + return + } + if (color[1] == ERR) { + call eprintf ("Color specification required\n") + return + } + + # if neither "on" nor "off", then turn off all, and turn + # on the specified frames + if (instruction == ERR) { + call cvdisplay (IDS_OFF , escape, short(IDS_EOD), + short(IDS_EOD), short(IDS_EOD)) + instruction = IDS_ON + } + call cvdisplay (instruction, escape, frames, color, quad) +end diff --git a/pkg/images/tv/iis/src/gwindow.h b/pkg/images/tv/iis/src/gwindow.h new file mode 100644 index 00000000..5050b304 --- /dev/null +++ b/pkg/images/tv/iis/src/gwindow.h @@ -0,0 +1,34 @@ +# Window descriptor structure. + +define LEN_WDES (5+(W_MAXWC+1)*LEN_WC+80) +define LEN_WC 10 # 4=[XbXeYbYe]+2=tr_type[xy] +define W_MAXWC 5 # max world coord systems +define W_SZIMSECT 79 # image section string + +define W_DEVICE Memi[$1] +define W_FRAME Memi[$1+1] # device frame number +define W_XRES Memi[$1+2] # device resolution, x +define W_YRES Memi[$1+3] # device resolution, y +define W_WC ($1+$2*LEN_WC+5) # ptr to coord descriptor +define W_IMSECT Memc[($1+65-1)*SZ_STRUCT+1] + +# Fields of the WC coordinate descriptor, a substructure of the window +# descriptor. "W_XB(W_WC(w,0))" is the XB field of wc 0 of window W. + +define W_XS Memr[P2R($1)] # starting X value +define W_XE Memr[P2R($1+1)] # ending X value +define W_XT Memi[$1+2] # X transformation type +define W_YS Memr[P2R($1+3)] # starting Y value +define W_YE Memr[P2R($1+4)] # ending Y value +define W_YT Memi[$1+5] # Y transformation type +define W_ZS Memr[P2R($1+6)] # starting Z value (greyscale) +define W_ZE Memr[P2R($1+7)] # ending Z value +define W_ZT Memi[$1+8] # Z transformation type +define W_UPTR Memi[$1+9] # LUT when ZT=USER + +# Types of coordinate and greyscale transformations. + +define W_UNITARY 0 # values map without change +define W_LINEAR 1 # linear mapping +define W_LOG 2 # logarithmic mapping +define W_USER 3 # user specifies transformation diff --git a/pkg/images/tv/iis/src/load1.x b/pkg/images/tv/iis/src/load1.x new file mode 100644 index 00000000..c33cc1dd --- /dev/null +++ b/pkg/images/tv/iis/src/load1.x @@ -0,0 +1,324 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +#### load1.x (from load.x) #### + +include +include +include +include +include +include +include +include "gwindow.h" +include "../lib/ids.h" +include "cv.h" + +# LOAD - Load an image. The specified image section is mapped into +# the specified section of an image display frame. The mapping involves +# a linear transformation in X and Y and a linear or logarithmic transformation +# in Z (greyscale). Images of all pixel datatypes are supported, and there +# no upper limit on the size of an image. The display device is interfaced +# via GIO metacode. + +procedure t_load() + +char image[SZ_FNAME] +short frame[IDS_MAXIMPL+1] +bool frame_erase, border_erase +pointer im, wdes, sp + +pointer gp +char device[SZ_FNAME] +int dd[LEN_GKIDD] + +int envgets() +short clgets() +bool clgetb() +pointer immap(), gopen() + +include "cv.com" +errchk immap, imunmap, ds_getparams + +begin + call smark (sp) + call salloc (cv_stack, CVLEN, TY_SHORT) + call salloc (wdes, LEN_WDES, TY_STRUCT) + + if (envgets ("stdimage", device, SZ_FNAME) == 0) + call error (EA_FATAL, + "variable 'stdimage' not defined in environment") + + call ids_open (device, dd) + call gki_inline_kernel (STDIMAGE, dd) + # Need READ_WRITE so can call cvdisplay + gp = gopen ( device, READ_WRITE, STDIMAGE) + + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + call ids_grstream (STDIMAGE) + + # to do: + # initialize local variables: image display size, etc + # instead of defines such as MCXSCALE, etc + + cv_maxframes = CV_MAXF + cv_maxgraph = CV_MAXG + cv_xcen = CV_XCEN + cv_ycen = CV_YCEN + cv_xres = CV_XRES + cv_yres = CV_YRES + cv_zres = CV_ZRES + cv_gp = gp + cv_xcon = real(GKI_MAXNDC+1)/CV_XRES + cv_ycon = real(GKI_MAXNDC+1)/CV_YRES + cv_grch = CV_GRCHNUM + cv_xwinc = -1. # Flag: Don't know what lut is + + # Open input imagefile. + call clgstr ("image", image, SZ_FNAME) + im = immap (image, READ_ONLY, 0) + + # Ultimately, we should get a sequence of frames, all of which get + # loaded with the same image. + + frame[1] = clgets ("frame") + frame[2] = IDS_EOD + frame_erase = clgetb ("erase") + + # Optimize for sequential i/o. + call imseti (im, IM_ADVICE, SEQUENTIAL) + + # The frame being displayed does not necessarily change when a new + # frame is loaded. (We might consider letting user select via the + # cv package) + + if (clgetb ("select_frame")) { + call cvdisplay (IDS_OFF, IDS_DISPLAY_I, short(IDS_EOD), + short(IDS_EOD), short(IDS_EOD)) + call cvdisplay (IDS_ON, IDS_DISPLAY_I, frame, short(IDS_EOD), + short(IDS_EOD)) + } + + if (frame_erase) + call cvcleari (frame) + + # Tell GIO what frame(s) to write + call cv_iset (frame) + + # Done with all possible read/write calls to cv package. Fix up so + # don't read device if we erase the frame, so need WRITE_ONLY mode. + # fseti on STDIMAGE didn't work. + + if (frame_erase) { + call gclose (gp) + call gki_inline_kernel (STDIMAGE, dd) + gp = gopen ( device, WRITE_ONLY, STDIMAGE) + cv_gp = gp + call fseti (STDIMAGE, F_TYPE, SPOOL_FILE) + call fseti (STDIMAGE, F_CANCEL, OK) + } + + # Get display parameters and set up transformation. + call ds_getparams (im, wdes, image, frame) + + # Erase the border (space between displayed image section and edge of + # window) only if screen was not erased and border erasing is enabled. + + if (frame_erase) + border_erase = false + else + border_erase = clgetb ("border_erase") + + # Display the image. + call ds_load_display (im, wdes, border_erase) + + call imunmap (im) + + # All done. + call gclose (gp) + call ids_close() + call sfree (sp) +end + + +# DS_GETPARAMS -- Get the parameters controlling how the image is mapped +# into the display frame. Set up the transformations and save in the graphics +# descriptor file. + +procedure ds_getparams (im, wdes, image, frame) + +pointer im, wdes # Image and graphics descriptors +char image[SZ_FNAME] # Should be determined from im +short frame[ARB] + +bool fill, zscale_flag, zrange_flag, zmap_flag +real xcenter, ycenter +real xsize, ysize, pxsize, pysize +real xmag, ymag, xscale, yscale +real z1, z2, contrast +int nsample_lines, ncols, nlines, len_stdline +pointer sp, w, ztrans, lut, lutfile + +bool clgetb() +int clgeti() +real clgetr() +bool streq() + +include "cv.com" + +begin + call smark (sp) + call salloc (ztrans, SZ_FNAME, TY_CHAR) + + # Set up a new graphics descriptor structure defining the coordinate + # transformation used to map the image into the display frame. + + call strcpy (image, W_IMSECT(wdes), W_SZIMSECT) + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # The fill, zscale, and zrange parameters determine the algorithms to + # be used to scale the image in the spatial and greyscale dimensions. + # If greyscale mapping is disabled the zscale and zrange options are + # disabled. Greyscale mapping can also be disabled by turning off + # zscale and zrange and setting Z1 and Z2 to the device greyscale min + # and max values, producing a unitary transformation. + + fill = clgetb ("fill") + call clgstr ("ztrans", Memc[ztrans], SZ_FNAME) + if (streq (Memc[ztrans], "none") || streq (Memc[ztrans], "user")) { + zscale_flag = false + zrange_flag = false + zmap_flag = false + } else { + zmap_flag = true + zscale_flag = clgetb ("zscale") + if (!zscale_flag) + zrange_flag = clgetb ("zrange") + } + + # Determine Z1 and Z2, the range of input greylevels to be mapped into + # the fixed range of display greylevels. + + if (zscale_flag) { + # Autoscaling is desired. Compute Z1 and Z2 which straddle the + # median computed by sampling a portion of the image. + + contrast = clgetr ("contrast") + nsample_lines = clgeti ("nsample_lines") + len_stdline = SAMPLE_SIZE / nsample_lines + call zscale (im, z1, z2, contrast, SAMPLE_SIZE, len_stdline) + + } else if (zrange_flag) { + nsample_lines = clgeti ("nsample_lines") + call maxmin (im, z1, z2, nsample_lines) + + } else if (zmap_flag) { + z1 = clgetr ("z1") + z2 = clgetr ("z2") + } + + # Determine the display window into which the image is to be mapped + # in normalized device coordinates. + + xcenter = max(0.0, min(1.0, clgetr ("xcenter"))) + ycenter = max(0.0, min(1.0, clgetr ("ycenter"))) + xsize = max(0.0, min(1.0, clgetr ("xsize"))) + ysize = max(0.0, min(1.0, clgetr ("ysize"))) + + # Determine X and Y scaling ratios required to map the image into the + # normalized display window. If spatial scaling is not desired filling + # must be disabled and XMAG and YMAG must be set to 1.0 in the + # parameter file. Fill mode will always produce an aspect ratio of 1; + # if nonequal scaling is required then the magnification ratios must + # be set explicitly by the user. + + if (fill) { + # Compute scale in units of window coords per data pixel required + # to scale image to fit window. + + xscale = xsize / max (1, (ncols - 1)) + yscale = ysize / max (1, (nlines - 1)) + + if (xscale < yscale) + yscale = xscale + else + xscale = yscale + + } else { + # Compute scale required to provide image magnification ratios + # specified by the user. Magnification is specified in units of + # display pixels, i.e, a magnification ratio of 1.0 means that + # image pixels will map to display pixels without scaling. + + xmag = clgetr ("xmag") + ymag = clgetr ("ymag") + xscale = 1.0 / ((cv_xres - 1) / xmag) + yscale = 1.0 / ((cv_yres - 1) / ymag) + } + + # Set device window limits in normalized device coordinates. + # World coord system 0 is used for the device window. + + w = W_WC(wdes,0) + W_XS(w) = xcenter - xsize / 2.0 + W_XE(w) = xcenter + xsize / 2.0 + W_YS(w) = ycenter - ysize / 2.0 + W_YE(w) = ycenter + ysize / 2.0 + + # Set pixel coordinates of window, world coordinate system #1. + + w = W_WC(wdes,1) + pxsize = xsize / xscale + pysize = ysize / yscale + + # If the image is too large to fit in the window given the scaling + # factors XSCALE and YSCALE, the following will set starting and ending + # pixel coordinates in the interior of the image. If the image is too + # small to fill the window then the pixel coords will reference beyond + # the bounds of the image. + + W_XS(w) = (ncols - 1) / 2.0 + 1 - (pxsize / 2.0) + W_XE(w) = W_XS(w) + pxsize + W_YS(w) = (nlines - 1) / 2.0 + 1 - (pysize / 2.0) + W_YE(w) = W_YS(w) + pysize + + # All spatial transformations are linear. + W_XT(w) = W_LINEAR + W_YT(w) = W_LINEAR + + # Determine whether a log or linear greyscale transformation is + # desired. + if (streq (Memc[ztrans], "log")) + W_ZT(w) = W_LOG + else if (streq (Memc[ztrans], "linear")) + W_ZT(w) = W_LINEAR + else if (streq (Memc[ztrans], "none")) + W_ZT(w) = W_UNITARY + else if (streq (Memc[ztrans], "user")) { + W_ZT(w) = W_USER + call salloc (lutfile, SZ_FNAME, TY_CHAR) + call clgstr ("lutfile", Memc[lutfile], SZ_FNAME) + call cv_ulut (Memc[lutfile], z1, z2, lut) + W_UPTR(w) = lut + } else { + call eprintf ("Bad greylevel transformation '%s'\n") + call pargstr (Memc[ztrans]) + W_ZT(w) = W_LINEAR + } + + # Set up the greyscale transformation. + W_ZS(w) = z1 + W_ZE(w) = z2 + + # Tell the user what values were used. + call printf ("cvl: z1 %6.1f, z2 %6.1f\n") + call pargr (z1) + call pargr (z2) + + # The user world coordinate system should be set from the CTRAN + # structure in the image header, but for now we just make it equal + # to the pixel coordinate system. + + call amovi (Memi[w], Memi[W_WC(wdes,2)], LEN_WC) +end diff --git a/pkg/images/tv/iis/src/load2.x b/pkg/images/tv/iis/src/load2.x new file mode 100644 index 00000000..5372907f --- /dev/null +++ b/pkg/images/tv/iis/src/load2.x @@ -0,0 +1,335 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +#### load2.x (from load.x) #### + +include +include +include +include +include +include +include +include "gwindow.h" +include "../lib/ids.h" +include "cv.h" + +# DS_LOAD_DISPLAY -- Map an image into the display window. In general this +# involves independent linear transformations in the X, Y, and Z (greyscale) +# dimensions. If a spatial dimension is larger than the display window then +# the image is block averaged. If a spatial dimension or a block averaged +# dimension is smaller than the display window then linear interpolation is +# used to expand the image. Both the input image and the output device appear +# to us as images, accessed via IMIO. +# +# World coordinate system 0 (WCS 0) defines the position and size of the device +# window in NDC coordinates (0-1 in either axis). WCS 1 assigns a pixel +# coordinate system to the same window. If we convert the NDC coordinates of +# the window into device coordinates in pixels, then the ratios of the window +# coordinates in pixels to the image coordinates in pixels defines the real +# magnification factors for the two spatial axes. If the pixel coordinates +# are out of bounds then the image will be displayed centered in the window +# with zero fill at the edges. If the frame has not been erased then the fill +# areas must be explicitly zeroed. + +procedure ds_load_display (im, wdes, border_erase) + +pointer im # input image +pointer wdes # graphics window descriptor +bool border_erase + +int wx1, wx2, wy1, wy2 # device window to be filled with image data +real px1, px2, py1, py2 # image coords in fractional image pixels +real pxsize, pysize # size of image section in fractional pixels +real wxcenter, wycenter # center of device window in frac device pixels +real xmag, ymag # x,y magnification ratios +pointer w0, w1 # world coord systems 0 (NDC) and 1 (pixel) + +include "cv.com" + +begin + # Compute pointers to WCS 0 and 1. + w0 = W_WC(wdes,0) + w1 = W_WC(wdes,1) + + # Compute X and Y magnification ratios required to map image into + # the device window in device pixel units. + + xmag = (W_XE(w0) - W_XS(w0)) * cv_xres / (W_XE(w1) - W_XS(w1)) + ymag = (W_YE(w0) - W_YS(w0)) * cv_yres / (W_YE(w1) - W_YS(w1)) + + # Compute the coordinates of the image section to be displayed. + # This is not necessarily the same as WCS 1 since the WCS coords + # need not be inbounds. + + px1 = max (1.0, W_XS(w1)) + px2 = min (real (IM_LEN(im,1)), W_XE(w1)) + py1 = max (1.0, W_YS(w1)) + py2 = min (real (IM_LEN(im,2)), W_YE(w1)) + + # Now compute the coordinates of the image section to be written in + # device pixel units. This section must lie within or on the device + # window. + # This computation for I2S will give 257, which does differ by one + # for the Y center (due to inversion in I2S). This should not matter, + # but if it does, this comment will change! + + pxsize = px2 - px1 + pysize = py2 - py1 + wxcenter = (W_XE(w0) + W_XS(w0)) / 2.0 * cv_xres + 1 + wycenter = (W_YE(w0) + W_YS(w0)) / 2.0 * cv_yres + 1 + + wx1 = max (1, int (wxcenter - (pxsize / 2.0 * xmag))) + wx2 = max (wx1, min (cv_xres, int (wx1 + (pxsize * xmag)))) + wy1 = max (1, int (wycenter - (pysize / 2.0 * ymag))) + wy2 = max (wy1, min (cv_yres, int (wy1 + (pysize * ymag)))) + + # Display the image data, ignoring zero filling at the boundaries. + + call ds_map_image (im, px1,px2,py1,py2, wx1,wx2,wy1,wy2, + W_ZS(w1), W_ZE(w1), W_ZT(w1), W_UPTR(w1)) + + # Zero the border of the window if the frame has not been erased, + # and if the displayed section does not occupy the full window. + + if (border_erase) + call ds_erase_border (im, wdes, wx1,wx2,wy1,wy2) +end + + +# DS_MAP_IMAGE -- Map an image section from the input image to a section +# (window) of the output image (the display device). All spatial scaling is +# handled by the "scaled input" package, i.e., SIGL2[SR]. Our task is to +# get lines from the scaled input image, transform the greyscale if necessary, +# and write the lines to the output device. + +procedure ds_map_image (im, px1,px2,py1,py2, wx1,wx2,wy1,wy2, z1,z2,zt, uptr) + +pointer im # input image +real px1,px2,py1,py2 # input section +int wx1,wx2,wy1,wy2 # output section +real z1,z2 # range of input greylevels to be mapped. +int zt # log or linear greylevel transformation +pointer uptr # pointer to user transformation table + +bool unitary_greyscale_transformation +short lut1, lut2, z1_s, z2_s, dz1_s, dz2_s +real dz1, dz2 +int wy, nx, ny, xblk, yblk +pointer in, out, si +pointer sigl2s(), sigl2r(), sigl2_setup() +errchk sigl2s, sigl2r, sigl2_setup +real xs, xe, y +pointer sp, outr +bool fp_equalr() +real if_elogr() +extern if_elogr + +include "cv.com" + +begin + call smark (sp) + + # Set up for scaled image input. + + nx = wx2 - wx1 + 1 + ny = wy2 - wy1 + 1 + xblk = INDEFI + yblk = INDEFI + si = sigl2_setup (im, px1,px2,nx,xblk, py1,py2,ny,yblk) + + # Output array, and limiting x values in NDC + + call salloc (out, nx, TY_SHORT) + xs = real(wx1 - 1) * cv_xcon / GKI_MAXNDC + # Don't subtract 1 from wx2 as we want it to be first one not filled + xe = real(wx2) * cv_xcon / GKI_MAXNDC + if ( xe > 1.0) + xe = 1.0 + + # The device ZMIN and ZMAX parameters define the acceptable range + # of greyscale values for the output device (e.g., 0-255 for most 8-bit + # display devices). For the general display, we use 0 and the + # device "z" resolution. Values Z1 and Z2 are mapped linearly or + # logarithmically into these. + + dz1 = 0 + dz2 = cv_zres-1 + + # If the user specified the transfer function, see that the + # intensity and greyscale values are in range. + + if (zt == W_USER) { + call alims (Mems[uptr], SZ_BUF, lut1, lut2) + dz1_s = short (dz1) + dz2_s = short (dz2) + if (lut2 < dz1_s || lut1 > dz2_s) + call eprintf ("User specified greyscales out of range\n") + if (z2 < IM_MIN(im) || z1 > IM_MAX(im)) + call eprintf ("User specified intensities out of range\n") + } + + # Type short pixels are treated as a special case to minimize vector + # operations for such images (which are common). If the image pixels + # are either short or real then only the ALTR (greyscale transformation) + # vector operation is required. The ALTR operator linearly maps + # greylevels in the range Z1:Z2 to DZ1:DZ2, and does a floor ceiling + # of DZ1:DZ2 on all pixels outside the range. If unity mapping is + # employed the data is simply copied, i.e., floor ceiling constraints + # are not applied. This is very fast and will produce a contoured + # image on the display which will be adequate for some applications. + + if (zt == W_UNITARY) + unitary_greyscale_transformation = true + else + unitary_greyscale_transformation = + (fp_equalr (dz1,z1) && fp_equalr (dz2,z2)) || fp_equalr (z1,z2) + + if (IM_PIXTYPE(im) == TY_SHORT && zt != W_LOG) { + + # Set dz1_s and dz2_s depending on transformation + if (zt != W_USER) { + dz1_s = short (dz1) + dz2_s = short (dz2) + } else { + dz1_s = short (STARTPT) + dz2_s = short (ENDPT) + } + z1_s = short (z1) + z2_s = short (z2) + + for (wy=wy1; wy <= wy2; wy=wy+1) { + in = sigl2s (si, wy - wy1 + 1) + y = real(wy-1) * cv_ycon / GKI_MAXNDC + if (unitary_greyscale_transformation) + call gpcell (cv_gp, Mems[in], nx, 1, xs, y, xe, y) + else if (zt == W_USER) { + call amaps (Mems[in], Mems[out], nx, z1_s,z2_s, dz1_s,dz2_s) + call aluts (Mems[out], Mems[out], nx, Mems[uptr]) + call gpcell (cv_gp, Mems[out], nx, 1, xs, y, xe, y) + } else { + call amaps (Mems[in], Mems[out], nx, z1_s,z2_s, dz1_s,dz2_s) + call gpcell (cv_gp, Mems[out], nx, 1, xs, y, xe, y) + } + } + } else { + call salloc (outr, nx, TY_REAL) + for (wy=wy1; wy <= wy2; wy=wy+1) { + in = sigl2r (si, wy - wy1 + 1) + y = real(wy - 1) * cv_ycon / GKI_MAXNDC + + if (zt == W_LOG) { + call amapr (Memr[in], Memr[outr], nx, + z1, z2, 1.0, 10.0 ** MAXLOG) + call alogr (Memr[outr], Memr[outr], nx, if_elogr) + call amapr (Memr[outr], Memr[outr], nx, + 1.0, real(MAXLOG), dz1, dz2) + call achtrs (Memr[outr], Mems[out], nx) + } else if (unitary_greyscale_transformation) { + call achtrs (Memr[in], Mems[out], nx) + } else if (zt == W_USER) { + call amapr (Memr[in], Memr[outr], nx, z1,z2, STARTPT,ENDPT) + call achtrs (Memr[outr], Mems[out], nx) + call aluts (Mems[out], Mems[out], nx, Mems[uptr]) + } else { + call amapr (Memr[in], Memr[outr], nx, z1, z2, dz1, dz2) + call achtrs (Memr[outr], Mems[out], nx) + } + call gpcell (cv_gp, Mems[out], nx, 1, xs, y, xe, y) + } + } + + call sfree (sp) + call sigl2_free (si) +end + + +# DS_ERASE_BORDER -- Zero the border of the window if the frame has not been +# erased, and if the displayed section does not occupy the full window. +# It would be more efficient to do this while writing the greyscale data to +# the output image, but that would complicate the display procedures and frames +# are commonly erased before displaying an image. + +procedure ds_erase_border (im, wdes, wx1,wx2,wy1,wy2) + +pointer im # input image +pointer wdes # window descriptor +int wx1,wx2,wy1,wy2 # section of display window filled by image data + +int dx1,dx2,dy1,dy2 # coords of full display window in device pixels +int j, n, n1 +pointer w0 +pointer sp, zero +real xls, xle, xrs, xre, y + +include "cv.com" + +begin + call smark (sp) + call salloc (zero, cv_xres, TY_SHORT) + call aclrs (Mems[zero], cv_xres) + + # Compute device pixel coordinates of the full display window. + w0 = W_WC(wdes,0) + dx1 = W_XS(w0) * (cv_xres - 1) + 1 + dx2 = W_XE(w0) * (cv_xres - 1) + 1 + dy1 = W_YS(w0) * (cv_yres - 1) + 1 + dy2 = W_YE(w0) * (cv_yres - 1) + 1 + + # Determine left and right (exclusive), start and end, x values in NDC + # for pixels not already filled. + # If, say, dx1 < wx1, we want to clear dx1 through wx1-1, which means + # that for gpcell, we want the (right) end points to be the first + # pixel not cleared. + xls = real(dx1 - 1) * cv_xcon / GKI_MAXNDC + xle = real(wx1) * cv_xcon / GKI_MAXNDC + if (xle > 1.0) + xle = 1.0 + xre = real(dx2 - 1) * cv_xcon / GKI_MAXNDC + xrs = real(wx2) * cv_xcon / GKI_MAXNDC + if (xre > 1.0) + xre = 1.0 + + # Erase lower margin. + n = dx2 - dx1 + 1 + for (j=dy1; j < wy1; j=j+1) { + y = real(j-1) * cv_ycon / GKI_MAXNDC + call gpcell (cv_gp, Mems[zero], n, 1, xls, y, xre, y) + } + + # Erase left and right margins. By doing the right margin of a line + # immediately after the left margin we have a high liklihood that the + # display line will still be in the FIO buffer. + + n = wx1 - dx1 + n1 = dx2 - wx2 + for (j=wy1; j <= wy2; j=j+1) { + y = real(j-1) * cv_ycon / GKI_MAXNDC + if (dx1 < wx1) + call gpcell (cv_gp, Mems[zero], n, 1, xls, y, xle, y) + if (wx2 < dx2) + call gpcell (cv_gp, Mems[zero], n1, 1, xrs, y, xre, y) + } + + # Erase upper margin. + n = dx2 - dx1 + 1 + for (j=wy2+1; j <= dy2; j=j+1) { + y = real(j-1) * cv_ycon / GKI_MAXNDC + call gpcell (cv_gp, Mems[zero], n, 1, xls, y, xre, y) + } + + call sfree (sp) +end + + +# IF_ELOG -- The error function for log10. Note that MAX_EXPONENT is +# currently an integer so it is converted to the appropriate data type +# before being returned. + +real procedure if_elogr (x) + +real x # the input pixel value + +begin + return (real(-MAX_EXPONENT)) +end + diff --git a/pkg/images/tv/iis/src/map.x b/pkg/images/tv/iis/src/map.x new file mode 100644 index 00000000..5ea7c230 --- /dev/null +++ b/pkg/images/tv/iis/src/map.x @@ -0,0 +1,320 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# MAP -- set fixed or variable LUT mapping + +procedure map(command) + +char command[ARB] + +char token[SZ_LINE] +int tok +short frames[IDS_MAXIMPL+2] # frames, graphics, EOD +short colors[IDS_MAXGCOLOR] +int device +short pcolor[2] +real limit +long seed +real urand(), xfactor +int ctoi() +int i, ip, iseed, level, nchar +bool triangle +pointer sp, rdata, gdata, bdata, rp, gp, bp + +include "cv.com" + +begin + # Find out if want to change output tables + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (( tok == TOK_IDENTIFIER) && (token[1] == 'o' )) { + device = IDS_OUTPUT_LUT + } else { + device = IDS_FRAME_LUT + # reset input pointers; same as having pushed back token + call reset_scan + call gargtok (tok, token, SZ_LINE) + } + + # Default to all frames, all colors + frames[1] = IDS_EOD + colors[1] = IDS_EOD + triangle = true # default to simple three function type + seed = -1 + level = 8 + + # which frames to change, colors, etc + + repeat { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + if (token[1] == 'f') { + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (token[1] == 'c') { + call cv_color (token[2], colors) + if (colors[1] == ERR) + return + } else if (token[1] == 'r') { # (random) level count + ip = 2 + nchar = ctoi (token, ip, level) + if (nchar <= 0) { + call eprintf ("Incorrect random count: %s\n") + call pargstr (token[2]) + return + } + if (level < 4) + level = 4 + else if (level > 128) + level = 128 + triangle = false + } else if (token[1] == 's') { # seed + ip = 2 + nchar = ctoi (token, ip, iseed) + if (nchar <= 0) { + call eprintf ("Incorrect seed: %s\n") + call pargstr (token[2]) + return + } + seed = iseed + triangle = false + } else { + call eprintf ("Unknown map argument: %s\n") + call pargstr (token) + return + } + } else if (tok != TOK_NEWLINE) { + call eprintf ("Unexpected map input: %s\n") + call pargstr (token) + return + } + } until ( tok == TOK_NEWLINE) + + pcolor[2] = IDS_EOD + # Sorry, but we "know" that ofm shouldn't go beyond first + # 256 for common NOAO use. + if ( device == IDS_FRAME_LUT) + limit = 1.0 + else + limit = 0.25 + + # Build the three functions and load them. + # First, expand colors if using all + + if (colors[1] == IDS_EOD) { + colors[1] = IDS_RED + colors[2] = IDS_GREEN + colors[3] = IDS_BLUE + colors[4] = IDS_EOD + } + + # if standard pseudocolor, let kodak do it + + if (triangle) { + call kodak (device, frames, colors, limit) + return + } + + # Not standard pseudo color -- do random one + # First, set up arrays + + call smark (sp) + call salloc (rdata, level*4, TY_SHORT) + call salloc (gdata, level*4, TY_SHORT) + call salloc (bdata, level*4, TY_SHORT) + + if (seed == -1) + seed = level + + call aclrs (Mems[rdata], level*4) + call aclrs (Mems[gdata], level*4) + call aclrs (Mems[bdata], level*4) + + xfactor = real(GKI_MAXNDC)/level * limit + + # set first data points to zero (0,0) to (1/level,0) + Mems[rdata+2] = xfactor + Mems[gdata+2] = xfactor + Mems[bdata+2] = xfactor + # Set last segment to white ((level-1)/level,1.0) to (1.0,1.0) + Mems[rdata+level*4-4] = real(level-1) * xfactor + Mems[gdata+level*4-4] = real(level-1) * xfactor + Mems[bdata+level*4-4] = real(level-1) * xfactor + Mems[rdata+level*4-3] = GKI_MAXNDC + Mems[gdata+level*4-3] = GKI_MAXNDC + Mems[bdata+level*4-3] = GKI_MAXNDC + Mems[rdata+level*4-2] = GKI_MAXNDC + Mems[gdata+level*4-2] = GKI_MAXNDC + Mems[bdata+level*4-2] = GKI_MAXNDC + Mems[rdata+level*4-1] = GKI_MAXNDC + Mems[gdata+level*4-1] = GKI_MAXNDC + Mems[bdata+level*4-1] = GKI_MAXNDC + + # Do the intermediate ones + do i=2, level-1 { + rp = rdata + (i-1)*4 + gp = gdata + (i-1)*4 + bp = bdata + (i-1)*4 + Mems[rp] = real(i-1) * xfactor + Mems[gp] = real(i-1) * xfactor + Mems[bp] = real(i-1) * xfactor + Mems[rp+1] = urand(seed) * GKI_MAXNDC + Mems[gp+1] = urand(seed) * GKI_MAXNDC + Mems[bp+1] = urand(seed) * GKI_MAXNDC + Mems[rp+2] = real(i) * xfactor + Mems[gp+2] = real(i) * xfactor + Mems[bp+2] = real(i) * xfactor + Mems[rp+3] = Mems[rp+1] + Mems[gp+3] = Mems[gp+1] + Mems[bp+3] = Mems[bp+1] + } + + # If color requested, do it + for ( i = 1; colors[i] != IDS_EOD; i = i + 1 ) { + pcolor[1] = colors[i] + switch (colors[i]) { + case IDS_RED: + call cvwlut (device, frames, pcolor, Mems[rdata], level*4) + + case IDS_GREEN: + call cvwlut (device, frames, pcolor, Mems[gdata], level*4) + + case IDS_BLUE: + call cvwlut (device, frames, pcolor, Mems[bdata], level*4) + } + } + + call sfree (sp) +end + +# KODAK -- provides three variable width and variable center triangular +# color mapping functions. + +procedure kodak (device, frames, colors, limit) + +int device # IDS_FRAME_LUT or IDS_OUTPUT_LUT +short frames[ARB] # frames to change +short colors[ARB] # colors to affect +real limit # factor to apply to limit x range + +short wdata[20], pcolor[2] +real center, width +int n, ksub(), button, i +int cv_rdbut(), cv_wtbut() + +begin + pcolor[2] = IDS_EOD + for (i = 1; colors[i] != IDS_EOD; i = i + 1) { + pcolor[1] = colors[i] + switch (colors[i]) { + case IDS_RED: + n = ksub (1.0, 0.5, wdata, limit) + + case IDS_GREEN: + n = ksub (0.5, 0.5, wdata, limit) + + case IDS_BLUE: + n = ksub (0.0, 0.5, wdata, limit) + } + + call cvwlut (device, frames, pcolor, wdata, n) + } + + button = cv_rdbut() # clear buttons + repeat { + call eprintf ("Press A, B, C for red, green, blue; D to exit\n") + button = cv_wtbut() + if (button == 4) + break + switch (button) { + case 1: + pcolor[1] = IDS_RED + + case 2: + pcolor[1] = IDS_GREEN + + case 3: + pcolor[1] = IDS_BLUE + } + + # Loop, reading cursor and modifying the display for the + # selected color. + + repeat { + call cv_rcraw(center, width) + width = width * 2. # flatten it + n = ksub (center, width, wdata, limit) + call cvwlut (device, frames, pcolor, wdata, n) + button = cv_rdbut() + } until (button != 0) + } +end + +# KSUB -- determines data points for a triangular mapping function +# Returns number of points in data array. + +int procedure ksub (center, width, data, limit) + +real center, width, limit +short data[ARB] + +int n +real xs, xe, ys, ye, xscale + +include "cv.com" + +begin + n = 0 + xscale = GKI_MAXNDC * limit + if (width < (1.0/cv_yres)) + width = 1.0/cv_yres + + if (center > 0.) { + xs = center - width + if (xs < 0.) + xs = 0. + else if (xs > 0.) { + data[1] = 0. + data[2] = 0. + n = n + 2 + } + ys = (xs - center)/width + 1.0 + data[n+1] = xs * xscale + data[n+2] = ys * GKI_MAXNDC + data[n+3] = center * xscale + data[n+4] = GKI_MAXNDC + n = n + 4 + } + + if (center < 1.0) { + xe = width + center + if (xe > 1.0) + xe = 1.0 + ye = (center - xe)/width + 1.0 + data[n+1] = center * xscale + data[n+2] = GKI_MAXNDC + data[n+3] = xe * xscale + data[n+4] = ye * GKI_MAXNDC + n = n + 4 + if (xe < 1.0) { + data[n+1] = xscale + data[n+2] = 0 + n = n + 2 + } + } + + # Extend last value to end + if (limit != 1.0) { + data[n+1] = GKI_MAXNDC + data[n+2] = data[n] + n = n + 2 + } + + return (n) +end diff --git a/pkg/images/tv/iis/src/match.x b/pkg/images/tv/iis/src/match.x new file mode 100644 index 00000000..ebbe523d --- /dev/null +++ b/pkg/images/tv/iis/src/match.x @@ -0,0 +1,172 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../lib/ids.h" + +# MATCH -- Match look up tables. The command reads +# match this_one (to) that one + +procedure match + +char token[SZ_LINE] +int tok +short f_ref[2] +short c_ref[IDS_MAXGCOLOR+1] +short frames[IDS_MAXIMPL+1] +short colors[IDS_MAXGCOLOR+1] +short nextcolor +int nchar, i, val, ctoi() +int ltype + +include "cv.com" + +begin + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if ( (tok == TOK_IDENTIFIER) && (token[1] == 'o') ) { + ltype = IDS_OUTPUT_LUT + } else { + ltype = IDS_FRAME_LUT + # "Push back" the token + call reset_scan + call gargtok (tok, token, SZ_LINE) + } + + # All this parsing tells us why YACC and LEX were invented + # Use "i" to tell if have parsed something useful + + i = -1 + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if ((tok == TOK_IDENTIFIER) && (token[1] == 'f')) { + i = 1 + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (tok == TOK_NUMBER) { + i = 1 + nchar = ctoi (token, i, val) + if ((val < 1) || (val > cv_maxframes)) { + call eprintf ("Invalid frame specification: %d\n") + call pargi (val) + return + } else { + frames[1] = val + frames[2] = IDS_EOD + } + } else if (ltype == IDS_FRAME_LUT) { + call eprintf ("missing frame arguement\n") + return + } else + frames[1] = IDS_EOD + + # default first color argument to all colors for both FRAME and OUTPUT + # tables...means make all colors the same. + + colors[1] = IDS_EOD # default all colors + + # Advance if previous token was useful + + if ( i != -1 ) { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + + # Look for a color + + if ((tok == TOK_IDENTIFIER) && (token[1] == 'c')) { + call cv_color (token[2], colors) + if (colors[1] == ERR) + return + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + + # look for fill word "to" + + if ((tok == TOK_IDENTIFIER) && (token[1] == 't')) { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + + # if FRAME LUT, we default frame to first frame to be changed. + # if OUTPUT LUT, frame is irrelevant + + i = -1 + if (tok == TOK_IDENTIFIER) { + if (token[1] == 'f') + i = 2 + else if (token[1] != 'c') { + call eprintf ("Unexpected argument: %s\n") + call pargstr (token) + return + } + } else if (tok == TOK_NUMBER) + i = 1 + + # if ltype is OUTPUT lut, don't care about frame type, but can't + # omit it...so default to EOD + + f_ref[1] = IDS_EOD + f_ref[2] = IDS_EOD + if (ltype == IDS_FRAME_LUT) { + if (i == -1) { + f_ref[1] = frames[1] + } else { + nchar = ctoi (token, i, val) + if ((val < 1) || (val > cv_maxframes)) { + call eprintf ("Invalid frame specification: %d\n") + call pargi (val) + return + } + f_ref[1] = val + } + } + + # Only thing left should be the reference color. + # If found a frame before, advance the token. + + if (i != -1) { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + } + if ((tok != TOK_NEWLINE) && (tok != TOK_IDENTIFIER)) { + call eprintf ("Unexpected input: %s\n") + call pargstr (token) + return + } + c_ref[1] = IDS_EOD + if (tok == TOK_IDENTIFIER) { + if (token[1] != 'c') { + call eprintf ("Unexpected input (color required): %s\n") + call pargstr (token) + return + } else { + call cv_color (token[2], c_ref) + if (c_ref[1] == ERR) + return + } + } + + if (c_ref[1] != IDS_EOD) + call cvmatch (ltype, f_ref, c_ref, frames, colors) + else { + # No specific color for reference. If no color specified + # to copy into, do all. + c_ref[2] = IDS_EOD + if ( colors[1] == IDS_EOD ) { + colors[1] = IDS_RED + colors[2] = IDS_GREEN + colors[3] = IDS_BLUE + colors[4] = IDS_EOD + } + # Match for each color given in "colors" + for ( i = 1 ; colors[i] != IDS_EOD; i = i + 1) { + nextcolor = colors[i+1] + colors[i+1] = IDS_EOD + c_ref[1] = colors[i] + call cvmatch (ltype, f_ref, c_ref, frames, colors[i]) + colors[i+1] = nextcolor + } + } +end diff --git a/pkg/images/tv/iis/src/maxmin.x b/pkg/images/tv/iis/src/maxmin.x new file mode 100644 index 00000000..d16874e9 --- /dev/null +++ b/pkg/images/tv/iis/src/maxmin.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +# MAXMIN -- Get the minimum and maximum pixel values of an image. If valid +# header values are available they are used, otherwise the image is sampled +# on an even grid and the min and max values of this sample are returned. + +procedure maxmin (im, zmin, zmax, nsample_lines) + +pointer im +real zmin, zmax # min and max intensity values +int nsample_lines # amount of image to sample + +int step, ncols, nlines, sample_size, imlines, i +real minval, maxval +pointer imgl2r() + +begin + # Only calculate minimum, maximum pixel values if the current + # values are unknown, or if the image was modified since the + # old values were computed. + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + # Use min and max values in image header if they are up to date. + zmin = IM_MIN(im) + zmax = IM_MAX(im) + + } else { + zmin = MAX_REAL + zmax = -MAX_REAL + + # Try to include a constant number of pixels in the sample + # regardless of the image size. The entire image is used if we + # have a small image, and at least sample_lines lines are read + # if we have a large image. + + sample_size = 512 * nsample_lines + imlines = min(nlines, max(nsample_lines, sample_size / ncols)) + step = nlines / (imlines + 1) + + do i = 1 + step, nlines, max (1, step) { + call alimr (Memr[imgl2r(im,i)], ncols, minval, maxval) + zmin = min (zmin, minval) + zmax = max (zmax, maxval) + } + } +end diff --git a/pkg/images/tv/iis/src/mkpkg b/pkg/images/tv/iis/src/mkpkg new file mode 100644 index 00000000..34ee515c --- /dev/null +++ b/pkg/images/tv/iis/src/mkpkg @@ -0,0 +1,39 @@ +# Make the CV display load and control package. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + blink.x ../lib/ids.h cv.com + clear.x ../lib/ids.h cv.com + cv.x cv.com cv.h ../lib/ids.h \ + + cvparse.x cv.com ../lib/ids.h + cvulut.x cv.h + cvutil.x cv.com cv.h ../lib/ids.h \ + cv.com + display.x ../lib/ids.h cv.com + load1.x cv.com cv.h ../lib/ids.h gwindow.h\ + + load2.x cv.com cv.h ../lib/ids.h gwindow.h\ + cv.com + map.x ../lib/ids.h cv.com + match.x ../lib/ids.h cv.com + maxmin.x + offset.x ../lib/ids.h cv.com + pan.x cv.com ../lib/ids.h + range.x ../lib/ids.h cv.com + rdcur.x ../lib/ids.h cv.com + reset.x ../lib/ids.h cv.com + sigl2.x + snap.x ../lib/ids.h cv.com \ + + split.x ../lib/ids.h cv.com + tell.x ../lib/ids.h cv.com + text.x ../lib/ids.h + window.x ../lib/ids.h cv.com + zoom.x ../lib/ids.h cv.com + zscale.x + ; diff --git a/pkg/images/tv/iis/src/offset.x b/pkg/images/tv/iis/src/offset.x new file mode 100644 index 00000000..356ae55f --- /dev/null +++ b/pkg/images/tv/iis/src/offset.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# OFFSET -- Change the bias (offset) for certain colors + +procedure offset() + +int tok, i, nchar, ip +char token[SZ_LINE] +short color[IDS_MAXGCOLOR+1] +short offsetdata[4] # extra space for cvmove EOD +int count, ctoi() + +include "cv.com" + +begin + # In principle, we should be able to accept input for color group + # followed by offset value(s) or "vice versa" or for a series of + # color/offset pairs. We try for most of that. + color[1] = ERR + offsetdata[1] = ERR + count = 1 + # anything but TOK_NEWLINE + tok = TOK_NUMBER + repeat { + if (tok == TOK_NEWLINE) { + call eprintf ("Insufficient offset specification\n") + return + } + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (token[1] == 'c') { + call cv_color (token[2], color) + if (color[1] == ERR) + return + } else if (tok == TOK_NUMBER) { + ip = 1 + nchar = ctoi (token, ip, i) + if ( count <= 3) { + offsetdata[count] = i + count = count + 1 + } + } + } until ( (color[1] != ERR) && (offsetdata[1] != ERR) && + (tok == TOK_NEWLINE) ) + + offsetdata[count] = IDS_EOD # mark end + + call cvoffset (color, offsetdata) +end diff --git a/pkg/images/tv/iis/src/pan.x b/pkg/images/tv/iis/src/pan.x new file mode 100644 index 00000000..b8929510 --- /dev/null +++ b/pkg/images/tv/iis/src/pan.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# PAN -- pan some or all of the frames + +procedure pan() + +char token[SZ_LINE] +int tok +short frames[IDS_MAXIMPL+2] # frames, graphics, EOD + +include "cv.com" + +begin + frames[1] = IDS_EOD # default all frames + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (token[1] == 'f') { + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (tok == TOK_NUMBER) { + call cv_frame (token[1], frames) + if (frames[1] == ERR) + return + } else { + call eprintf ("Unexpected input: %s\n") + call pargstr (token) + return + } + + call pansub (frames) +end + + +# PANSUB -- Pan subroutine, handles code common to pan and zoom + +procedure pansub (frames) + +short frames[ARB] # frames to pan + +int button +int cnum, cv_rdbut() +real x,y, xc, yc +real oldx, oldy + +include "cv.com" + +begin + button = cv_rdbut() # clear buttons by reading them + call eprintf ("Press any button when done\n") + + # Where is cursor now? + + call cv_rcraw (xc,yc) + + # Calculate NDC screen center and cursor number. + # x,y are NDC, but always < 1.0 The transformation applied here + # insures that the correct pixel is calculated by the kernel + # after passing x,y through the gio cursor routines. + x = real(cv_xcen - 1) * cv_xcon / GKI_MAXNDC + y = real(cv_ycen - 1) * cv_ycon / GKI_MAXNDC + cnum = frames[1] + if (cnum == IDS_EOD) + cnum = 0 + call cv_scraw (x, y) # put cursor at screen center + + # Determine NDC there for frame of interest + call cv_rcur (cnum, x, y) + + # Restore cursor + call cv_scraw (xc, yc) + + repeat { + oldx = xc + oldy = yc + repeat { + call cv_rcraw (xc, yc) + button = cv_rdbut() + } until ( (xc != oldx) || (yc != oldy) || (button > 0)) + # Determine change and reflect it about current screen + # center so image moves in direction cursor moves. + x = x - (xc - oldx) + y = y - (yc - oldy) + if (x > 1.0) + x = x - 1.0 + else if (x < 0) + x = x + 1.0 + if (y > 1.0) + y = y - 1.0 + else if (y < 0) + y = y + 1.0 + call cvpan (frames, x, y) + } until (button > 0) +end diff --git a/pkg/images/tv/iis/src/range.x b/pkg/images/tv/iis/src/range.x new file mode 100644 index 00000000..664e3ab8 --- /dev/null +++ b/pkg/images/tv/iis/src/range.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# RANGE -- set the scaling (range) registers + +procedure range() + +char token[SZ_LINE] +int tok, i, nchar, ip +short color[IDS_MAXGCOLOR+1] +short rdata[4] # extra space for cvmove EOD +int count, ctoi() + +include "cv.com" + +begin + # In principle, we should be able to accept input for color group + # followed by range value(s) or "vice versa" or for a series of + # color/range pairs. We try for most of that. + color[1] = IDS_EOD + rdata[1] = ERR + count = 1 + # anything but TOK_NEWLINE + tok = TOK_NUMBER + repeat { + if (tok == TOK_NEWLINE) { + call eprintf ("Insufficient range specification\n") + return + } + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (token[1] == 'c') { + call cv_color (token[2], color) + if (color[1] == ERR) + return + } else if (tok == TOK_NUMBER) { + ip = 1 + nchar = ctoi (token, ip, i) + if (i < 1) { + call eprintf ("bad range specification: %d\n") + call pargi (i) + return + } + if ( count <= 3) { + rdata[count] = i + count = count + 1 + } + } + } until ( (rdata[1] != ERR) && (tok == TOK_NEWLINE )) + + rdata[count] = IDS_EOD # mark end + + call cvrange ( color, rdata) +end diff --git a/pkg/images/tv/iis/src/rdcur.x b/pkg/images/tv/iis/src/rdcur.x new file mode 100644 index 00000000..5d27097e --- /dev/null +++ b/pkg/images/tv/iis/src/rdcur.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# RDCUR -- read cursor and datum + +procedure rdcur() + +char token[SZ_LINE], ch +int tok, cnum, px, py +int junk, ip, fx, fy +real x,y +short datum +short frames[IDS_MAXIMPL+2] # frames, one graphics, EOD +int scan(), ctoi(), mod(), and() + +include "cv.com" + +begin + cnum = ERR + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_NUMBER) { + ip = 1 + junk = ctoi (token, ip, cnum) + frames[1] = cnum + frames[2] = IDS_EOD + } + else if (tok == TOK_IDENTIFIER) { + if (token[1] == 'o') { + if (token[2] == 'n') + call cvcur(IDS_ON) + else if (token[2] == 'f') + call cvcur(IDS_OFF) + else { + call eprintf ("Unrecognized cursor command: %s\n") + call pargstr (token) + } + return + } + call cv_frame (token[2], frames) + cnum = frames[1] + if ( cnum == IDS_EOD) { + call eprintf ("Please specify a particular frame\n") + return + } + } + if ( (cnum == ERR) || (cnum < 1) ) { + call eprintf ("bad cursor number: %d\n") + call pargi (cnum) + return + } + + # set kernel to do i/o on specified frames (for ggcell routine) + call cv_iset (frames) + + call eprintf ("Press for each read; any key but , and then , to exit\n") + repeat { + if (scan() != EOS) + break + repeat { + call scanc (ch) + } until (ch != ' ') + if (ch != '\n') + break + call cv_rcur (cnum, x, y) + call ggcell (cv_gp, datum, 1, 1, x, y, x, y) + x = x * GKI_MAXNDC / cv_xcon + 1. + y = y * GKI_MAXNDC / cv_ycon + 1. + px = int(x) + py = int(y) + # Only allow fractions to 1/8 as that is max zoom for IIS + x = real (int((x - px)*8))/8. + y = real (int((y - py)*8))/8. + # Print minimum number of decimal places, but do x and y the same + call eprintf ("frame %d, pixel (") + call pargi (cnum) + fx = x * 8 + fy = y * 8 + if ((fx == 0) && (fy == 0)) { + call eprintf ("%d,%d") + call pargi (px) + call pargi (py) + junk = 0 + } else { + call eprintf ("%.*f,%.*f") + + if ( (mod(fx,4) == 0) && (mod(fy,4) == 0) ) + junk = 1 + else if ( (and(fx,1) != 0) || (and(fy,1) != 0) ) + junk = 3 + else + junk = 2 + + call pargi (junk) + call pargr (px+x) + call pargi (junk) + call pargr (py+y) + } + if (junk == 0) + junk = 8 + else + junk = 6 - 2 * junk + call eprintf ("): %*w%4d\n") + call pargi (junk) + call pargs (datum) + } +end diff --git a/pkg/images/tv/iis/src/reset.x b/pkg/images/tv/iis/src/reset.x new file mode 100644 index 00000000..3a2e60e9 --- /dev/null +++ b/pkg/images/tv/iis/src/reset.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# RESET -- reset the display + +procedure reset() + +char token[SZ_LINE] +int tok + +include "cv.com" + +begin + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + switch(token[1]) { + case 'r': + call cvreset( IDS_R_SOFT) + + case 't': + call cvreset( IDS_R_MEDIUM) + + case 'i': + call cvreset( IDS_R_HARD) + + case 'a': + call cvreset( IDS_R_SOFT) + call cvreset( IDS_R_MEDIUM) + call cvreset( IDS_R_HARD) + + } + } +end diff --git a/pkg/images/tv/iis/src/sigl2.x b/pkg/images/tv/iis/src/sigl2.x new file mode 100644 index 00000000..226d4f5b --- /dev/null +++ b/pkg/images/tv/iis/src/sigl2.x @@ -0,0 +1,677 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +.help sigl2, sigl2_setup +.nf ___________________________________________________________________________ +SIGL2 -- Get a line from a spatially scaled 2-dimensional image. This procedure +works like the regular IMIO get line procedure, but rescales the input +2-dimensional image in either or both axes upon input. If the magnification +ratio required is greater than 0 and less than 2 then linear interpolation is +used to resample the image. If the magnification ratio is greater than or +equal to 2 then the image is block averaged by the smallest factor which +reduces the magnification to the range 0-2 and then interpolated back up to +the desired size. In some cases this will smooth the data slightly, but the +operation is efficient and avoids aliasing effects. + + si = sigl2_setup (im, x1,x2,nx, y1,y2,ny) + sigl2_free (si) + ptr = sigl2[sr] (si, linenumber) + +SIGL2_SETUP must be called to set up the transformations after mapping the +image and before performing any scaled i/o to the image. SIGL2_FREE must be +called when finished to return buffer space. +.endhelp ______________________________________________________________________ + +# Scaled image descriptor for 2-dim images + +define SI_LEN 15 +define SI_MAXDIM 2 # images of 2 dimensions supported +define SI_NBUFS 3 # nbuffers used by SIGL2 + +define SI_IM Memi[$1] # pointer to input image header +define SI_GRID Memi[$1+1+$2-1] # pointer to array of X coords +define SI_NPIX Memi[$1+3+$2-1] # number of X coords +define SI_BAVG Memi[$1+5+$2-1] # X block averaging factor +define SI_INTERP Memi[$1+7+$2-1] # interpolate X axis +define SI_BUF Memi[$1+9+$2-1] # line buffers +define SI_TYBUF Memi[$1+12] # buffer type +define SI_XOFF Memi[$1+13] # offset in input image to first X +define SI_INIT Memi[$1+14] # YES until first i/o is done + +define OUTBUF SI_BUF($1,3) + +define SI_TOL (1E-5) # close to a pixel +define INTVAL (abs ($1 - nint($1)) < SI_TOL) +define SWAPI {tempi=$2;$2=$1;$1=tempi} +define SWAPP {tempp=$2;$2=$1;$1=tempp} +define NOTSET (-9999) + +# SIGL2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute +# the block averaging factors (1 if no block averaging is required) and +# the sampling grid points, i.e., pixel coordinates of the output pixels in +# the input image. +# +# Valdes - Jan 9, 1985: +# Nx or ny can be 1 and blocking factors can be specified. + +pointer procedure sigl2_setup (im, px1, px2, nx, xblk, py1, py2, ny, yblk) + +pointer im # the input image +real px1, px2 # range in X to be sampled on an even grid +int nx # number of output pixels in X +int xblk # blocking factor in x +real py1, py2 # range in Y to be sampled on an even grid +int ny # number of output pixels in Y +int yblk # blocking factor in y + +int npix, noldpix, nbavpix, i, j +int npts[SI_MAXDIM] # number of output points for axis +int blksize[SI_MAXDIM] # block averaging factor (npix per block) +real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels +real p1[SI_MAXDIM] # starting pixel coords in each axis +real p2[SI_MAXDIM] # ending pixel coords in each axis +real scalar, start +pointer si, gp + +begin + iferr (call calloc (si, SI_LEN, TY_STRUCT)) + call erract (EA_FATAL) + + SI_IM(si) = im + SI_NPIX(si,1) = nx + SI_NPIX(si,2) = ny + SI_INIT(si) = YES + + p1[1] = px1 # X = index 1 + p2[1] = px2 + npts[1] = nx + blksize[1] = xblk + + p1[2] = py1 # Y = index 2 + p2[2] = py2 + npts[2] = ny + blksize[2] = yblk + + # Compute block averaging factors if not defined. + # If there is only one pixel then the block average is the average + # between the first and last point. + + do i = 1, SI_MAXDIM { + if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { + if (npts[i] == 1) + tau[i] = 0. + else + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else { + if (npts[i] == 1) { + tau[i] = 0. + blksize[i] = int (p2[i] - p1[i] + 1) + } else { + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + if (tau[i] >= 2.0) { + + # If nx or ny is not an integral multiple of the block + # averaging factor, noldpix is the next larger number + # which is an integral multiple. When the image is + # block averaged pixels will be replicated as necessary + # to fill the last block out to this size. + + blksize[i] = int (tau[i]) + npix = p2[i] - p1[i] + 1 + noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] + nbavpix = noldpix / blksize[i] + scalar = real (nbavpix - 1) / real (noldpix - 1) + p1[i] = (p1[i] - 1.0) * scalar + 1.0 + p2[i] = (p2[i] - 1.0) * scalar + 1.0 + tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) + } else + blksize[i] = 1 + } + } + } + + SI_BAVG(si,1) = blksize[1] + SI_BAVG(si,2) = blksize[2] + + if (IS_INDEFI (xblk)) + xblk = blksize[1] + if (IS_INDEFI (yblk)) + yblk = blksize[2] + + # Allocate and initialize the grid arrays, specifying the X and Y + # coordinates of each pixel in the output image, in units of pixels + # in the input (possibly block averaged) image. + + do i = 1, SI_MAXDIM { + # The X coordinate is special. We do not want to read entire + # input image lines if only a range of input X values are needed. + # Since the X grid vector passed to ALUI (the interpolator) must + # contain explicit offsets into the vector being interpolated, + # we must generate interpolator grid points starting near 1.0. + # The X origin, used to read the block averaged input line, is + # given by XOFF. + + if (i == 1) { + SI_XOFF(si) = int (p1[i]) + start = p1[1] - int (p1[i]) + 1.0 + } else + start = p1[i] + + # Do the axes need to be interpolated? + if (INTVAL(start) && INTVAL(tau[i])) + SI_INTERP(si,i) = NO + else + SI_INTERP(si,i) = YES + + # Allocate grid buffer and set the grid points. + iferr (call malloc (gp, npts[i], TY_REAL)) + call erract (EA_FATAL) + SI_GRID(si,i) = gp + do j = 0, npts[i]-1 + Memr[gp+j] = start + (j * tau[i]) + } + + return (si) +end + + +# SIGL2_FREE -- Free storage associated with an image opened for scaled +# input. This does not close and unmap the image. + +procedure sigl2_free (si) + +pointer si +int i + +begin + # Free SIGL2 buffers. + do i = 1, SI_NBUFS + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + + # Free GRID buffers. + do i = 1, SI_MAXDIM + if (SI_GRID(si,i) != NULL) + call mfree (SI_GRID(si,i), TY_REAL) + + call mfree (si, TY_STRUCT) +end + + +# SIGL2S -- Get a line of type short from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigl2s (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, buf_y[2], new_y[2], tempi, curbuf, altbuf +int npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blkavgs() +errchk si_blkavgs + +begin + npix = SI_NPIX(si,1) + + # Determine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blkavgs (SI_IM(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_SHORT) + SI_TYBUF(si) = TY_SHORT + buf_y[i] = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_SHORT) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == buf_y[i]) { + ; + } else if (new_y[i] == buf_y[altbuf]) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (buf_y[1], buf_y[2]) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blkavgs (SI_IM(si), x1, x2, new_y[i], + SI_BAVG(si,1), SI_BAVG(si,2)) + + if (SI_INTERP(si,1) == NO) + call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) + else { + call aluis (Mems[rawline], Mems[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + buf_y[i] = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from buf_y[1] to buf_y[2] is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - buf_y[1]) + weight_2 = 1.0 - weight_1 + + if (weight_2 < SI_TOL) + return (SI_BUF(si,1)) + else if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else { + call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], + Mems[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLKAVGS -- Get a line from a block averaged image of type short. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blkavgs (im, x1, x2, y, xbavg, ybavg) + +pointer im # input image +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors + +short temp_s +int nblks_x, nblks_y, ncols, nlines, xoff, i, j +int first_line, nlines_in_sum, npix, nfull_blks, count +real sum +pointer sp, a, b +pointer imgs2s() +errchk imgs2s + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blkavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blkavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (imgs2s (im, xoff, xoff + npix - 1, y, y)) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blkavg: block number out of range") + + call salloc (b, nblks_x, TY_SHORT) + + if (ybavg > 1) { + call aclrs (Mems[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = imgs2s (im, xoff, xoff + npix - 1, i, i) + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + call abavs (Mems[a], Mems[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Mems[a+j-1] + count = count + 1 + } + Mems[a+nblks_x-1] = sum / count + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + if (ybavg > 1) { + call aadds (Mems[a], Mems[b], Mems[b], nblks_x) + nlines_in_sum = nlines_in_sum + 1 + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) { + temp_s = nlines_in_sum + call adivks (Mems[b], temp_s, Mems[a], nblks_x) + } + + call sfree (sp) + return (a) +end + + +# SIGL2R -- Get a line of type real from a scaled image. Block averaging is +# done by a subprocedure; this procedure gets a line from a possibly block +# averaged image and if necessary interpolates it to the grid points of the +# output line. + +pointer procedure sigl2r (si, lineno) + +pointer si # pointer to SI descriptor +int lineno + +pointer rawline, tempp, gp +int i, buf_y[2], new_y[2], tempi, curbuf, altbuf +int npix, nblks_y, ybavg, x1, x2 +real x, y, weight_1, weight_2 +pointer si_blkavgr() +errchk si_blkavgr + +begin + npix = SI_NPIX(si,1) + + # Deterine the range of X (in pixels on the block averaged input image) + # required for the interpolator. + + gp = SI_GRID(si,1) + x1 = SI_XOFF(si) + x = Memr[gp+npix-1] + x2 = x1 + int(x) + if (INTVAL(x)) + x2 = x2 - 1 + x2 = max (x1 + 1, x2) + + gp = SI_GRID(si,2) + y = Memr[gp+lineno-1] + + # The following is an optimization provided for the case when it is + # not necessary to interpolate in either X or Y. Block averaging is + # permitted. + + if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) + return (si_blkavgr (SI_IM(si), x1, x2, int(y), + SI_BAVG(si,1), SI_BAVG(si,2))) + + # If we are interpolating in Y two buffers are required, one for each + # of the two input image lines required to interpolate in Y. The lines + # stored in these buffers are interpolated in X to the output grid but + # not in Y. Both buffers are not required if we are not interpolating + # in Y, but we use them anyhow to simplify the code. + + if (SI_INIT(si) == YES) { + do i = 1, 2 { + if (SI_BUF(si,i) != NULL) + call mfree (SI_BUF(si,i), SI_TYBUF(si)) + call malloc (SI_BUF(si,i), npix, TY_REAL) + SI_TYBUF(si) = TY_REAL + buf_y[i] = NOTSET + } + if (OUTBUF(si) != NULL) + call mfree (OUTBUF(si), SI_TYBUF(si)) + call malloc (OUTBUF(si), npix, TY_REAL) + SI_INIT(si) = NO + } + + # If the Y value of the new line is not in range of the contents of the + # current line buffers, refill one or both buffers. To refill we must + # read a (possibly block averaged) input line and interpolate it onto + # the X grid. The X and Y values herein are in the coordinate system + # of the (possibly block averaged) input image. + + new_y[1] = int(y) + new_y[2] = int(y) + 1 + + # Get the pair of lines whose integral Y values form an interval + # containing the fractional Y value of the output line. Sometimes the + # desired line will happen to be in the other buffer already, in which + # case we just have to swap buffers. Often the new line will be the + # current line, in which case nothing is done. This latter case occurs + # frequently when the magnification ratio is large. + + curbuf = 1 + altbuf = 2 + + do i = 1, 2 { + if (new_y[i] == buf_y[i]) { + ; + } else if (new_y[i] == buf_y[altbuf]) { + SWAPP (SI_BUF(si,1), SI_BUF(si,2)) + SWAPI (buf_y[1], buf_y[2]) + + } else { + # Get line and interpolate onto output grid. If interpolation + # is not required merely copy data out. This code is set up + # to always use two buffers; in effect, there is one buffer of + # look ahead, even when Y[i] is integral. This means that we + # will go out of bounds by one line at the top of the image. + # This is handled by copying the last line. + + ybavg = SI_BAVG(si,2) + nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg + if (new_y[i] <= nblks_y) + rawline = si_blkavgr (SI_IM(si), x1, x2, new_y[i], + SI_BAVG(si,1), SI_BAVG(si,2)) + + if (SI_INTERP(si,1) == NO) + call amovr (Memr[rawline], Memr[SI_BUF(si,i)], npix) + else { + call aluir (Memr[rawline], Memr[SI_BUF(si,i)], + Memr[SI_GRID(si,1)], npix) + } + + buf_y[i] = new_y[i] + } + + SWAPI (altbuf, curbuf) + } + + # We now have two line buffers straddling the output Y value, + # interpolated to the X grid of the output line. To complete the + # bilinear interpolation operation we take a weighted sum of the two + # lines. If the range from buf_y[1] to buf_y[2] is repeatedly + # interpolated in Y no additional i/o occurs and the linear + # interpolation operation (ALUI) does not have to be repeated (only the + # weighted sum is required). If the distance of Y from one of the + # buffers is zero then we do not even have to take a weighted sum. + # This is not unusual because we may be called with a magnification + # of 1.0 in Y. + + weight_1 = 1.0 - (y - buf_y[1]) + weight_2 = 1.0 - weight_1 + + if (weight_2 < SI_TOL) + return (SI_BUF(si,1)) + else if (weight_1 < SI_TOL) + return (SI_BUF(si,2)) + else { + call awsur (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], + Memr[OUTBUF(si)], npix, weight_1, weight_2) + return (OUTBUF(si)) + } +end + + +# SI_BLKAVGR -- Get a line from a block averaged image of type short. +# For example, block averaging by a factor of 2 means that pixels 1 and 2 +# are averaged to produce the first output pixel, 3 and 4 are averaged to +# produce the second output pixel, and so on. If the length of an axis +# is not an integral multiple of the block size then the last pixel in the +# last block will be replicated to fill out the block; the average is still +# defined even if a block is not full. + +pointer procedure si_blkavgr (im, x1, x2, y, xbavg, ybavg) + +pointer im # input image +int x1, x2 # range of x blocks to be read +int y # y block to be read +int xbavg, ybavg # X and Y block averaging factors + +int nblks_x, nblks_y, ncols, nlines, xoff, i, j +int first_line, nlines_in_sum, npix, nfull_blks, count +real sum +pointer sp, a, b +pointer imgs2r() +errchk imgs2r + +begin + call smark (sp) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + xoff = (x1 - 1) * xbavg + 1 + npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) + + if ((xbavg < 1) || (ybavg < 1)) + call error (1, "si_blkavg: illegal block size") + else if (x1 < 1 || x2 > ncols) + call error (2, "si_blkavg: column index out of bounds") + else if ((xbavg == 1) && (ybavg == 1)) + return (imgs2r (im, xoff, xoff + npix - 1, y, y)) + + nblks_x = (npix + xbavg-1) / xbavg + nblks_y = (nlines + ybavg-1) / ybavg + + if (y < 1 || y > nblks_y) + call error (2, "si_blkavg: block number out of range") + + call salloc (b, nblks_x, TY_REAL) + + if (ybavg > 1) { + call aclrr (Memr[b], nblks_x) + nlines_in_sum = 0 + } + + # Read and accumulate all input lines in the block. + first_line = (y - 1) * ybavg + 1 + + do i = first_line, min (nlines, first_line + ybavg - 1) { + # Get line from input image. + a = imgs2r (im, xoff, xoff + npix - 1, i, i) + + # Block average line in X. + if (xbavg > 1) { + # First block average only the full blocks. + nfull_blks = npix / xbavg + call abavr (Memr[a], Memr[a], nfull_blks, xbavg) + + # Now average the final partial block, if any. + if (nfull_blks < nblks_x) { + sum = 0.0 + count = 0 + do j = nfull_blks * xbavg + 1, npix { + sum = sum + Memr[a+j-1] + count = count + 1 + } + Memr[a+nblks_x-1] = sum / count + } + } + + # Add line into block sum. Keep track of number of lines in sum + # so that we can compute block average later. + if (ybavg > 1) { + call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) + nlines_in_sum = nlines_in_sum + 1 + } + } + + # Compute the block average in Y from the sum of all lines block + # averaged in X. Overwrite buffer A, the buffer returned by IMIO. + # This is kosher because the block averaged line is never longer + # than an input line. + + if (ybavg > 1) + call adivkr (Memr[b], real(nlines_in_sum), Memr[a], nblks_x) + + call sfree (sp) + return (a) +end diff --git a/pkg/images/tv/iis/src/snap.x b/pkg/images/tv/iis/src/snap.x new file mode 100644 index 00000000..12694568 --- /dev/null +++ b/pkg/images/tv/iis/src/snap.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "../lib/ids.h" + +# SNAP -- Take a picture!! + +procedure snap() + +char token[SZ_LINE] +int tok +char fname[SZ_FNAME] +int snap_color + +include "cv.com" + +begin + snap_color = IDS_SNAP_MONO # default color for snap + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + if (token[1] != 'c') { + call eprintf ("unknown snap argument: %s\n") + call pargstr (token) + return + } else { + # snap colors: r, g, b, rgb, m (monochrome) == bw (black/white) + switch (token[2]) { + case 'm': + snap_color = IDS_SNAP_MONO + + case 'r': + if ((token[3] == 'g') && (token[4] == 'b') ) + snap_color = IDS_SNAP_RGB + else + snap_color = IDS_SNAP_RED + + case 'g': + snap_color = IDS_SNAP_GREEN + + case 'b': + if (token[3] == 'w') + snap_color = IDS_SNAP_MONO + else + snap_color = IDS_SNAP_BLUE + + default: + call eprintf ("Unknown snap color: %c\n") + call pargc (token[2]) + return + } + } + } else if (tok != TOK_NEWLINE) { + call eprintf ("unexpected argument to snap: %s\n") + call pargstr (token) + return + } + + call clgstr("snap_file", fname, SZ_FNAME) + call cvsnap (fname, snap_color) +end diff --git a/pkg/images/tv/iis/src/split.x b/pkg/images/tv/iis/src/split.x new file mode 100644 index 00000000..393fc218 --- /dev/null +++ b/pkg/images/tv/iis/src/split.x @@ -0,0 +1,95 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# SPLIT -- set the split screen point + +procedure split() + +char token[SZ_LINE] +int tok +int nchar, ctoi() +int i, x, y +real xr, yr +int ctor() +bool a_real + +define errmsg 10 + +include "cv.com" + +begin + a_real = false + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + switch(token[1]) { + case 'c': + x = cv_xcen + y = cv_ycen + + case 'o': + x = 1 + y = 1 + + case 'n', 'p': # n: ndc, p: pixel + if (token[1] == 'n') + a_real = true + if (IS_DIGIT(token[2])) + i = 2 + else { + call gargtok (tok, token, SZ_LINE) + if (tok != TOK_NUMBER) { +errmsg + call eprintf ("bad split pixel: %s\n") + call pargstr (token) + return + } else + i = 1 + } + if (a_real) + nchar = ctor (token, i, xr) + else + nchar = ctoi (token, i, x) + if (nchar == 0) { + call eprintf ("No conversion, ") + goto errmsg + } + call gargtok (tok, token, SZ_LINE) + if (tok == TOK_PUNCTUATION) + call gargtok (tok, token, SZ_LINE) + i = 1 + if (a_real) + nchar = ctor (token, i, yr) + else + nchar = ctoi (token, i, y) + if (nchar == 0) { + call eprintf ("No conversion, ") + goto errmsg + } + + default: + call eprintf ("unknown split code: %c\n") + call pargc (token[1]) + return + } + } + # Convert to NDC, BUT note, that as x and y range from 1 through + # cv_[xy]res, xr and yr will never be 1.0---and they must not be + # (see cvsplit()) + if (!a_real ) { + xr = real(x-1) / cv_xres + yr = real(y-1) / cv_xres + } + if ( xr < 0 ) + xr = 0 + if ( yr < 0 ) + yr = 0 + if ( xr >= 1.0 ) + xr = real(cv_xres-1)/cv_xres + if ( yr >= 1.0 ) + yr = real(cv_yres-1)/cv_yres + call cvsplit (xr, yr) +end diff --git a/pkg/images/tv/iis/src/tell.x b/pkg/images/tv/iis/src/tell.x new file mode 100644 index 00000000..cce4987e --- /dev/null +++ b/pkg/images/tv/iis/src/tell.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +include "../lib/ids.h" + +# TELL -- Tell user about display state + +procedure tell() + +short f[IDS_MAXIMPL+2] # Ultimately, want an array terminated + # with IDS_EOD as usual + +include "cv.com" + +begin + # We don't know much, do we? + + call cvwhich(f) + if ( f[1] > 0) { + call eprintf ("Frame %d, at least, is on.\n") + call pargs (f[1]) + } else + call eprintf ("No frames are on.\n") +end diff --git a/pkg/images/tv/iis/src/text.x b/pkg/images/tv/iis/src/text.x new file mode 100644 index 00000000..32623786 --- /dev/null +++ b/pkg/images/tv/iis/src/text.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../lib/ids.h" + +# TEXT -- put text into image planes or graphics bit planes + +procedure text() + +char token[SZ_LINE] +int tok, ip, cnum +short frames[IDS_MAXIMPL+2] # frames, graphics, EOD +short colors[IDS_MAXGCOLOR] +real x, y +int button, cv_wtbut() +char line[SZ_LINE] +real size, clgetr() + +begin + frames[1] = ERR + colors[1] = ERR + + # which frames for text + + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + if (token[1] == 'f') { + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (token[1] == 'c') { + call cv_color (token[2], colors) + if (colors[1] == ERR) + return + } + } else if (tok == TOK_NUMBER) { + call cv_frame (token[1], frames) + if (frames[1] == ERR) + return + } + if ( (frames[1] == ERR) && (colors[1] == ERR)) { + call eprintf ("Inadequate text specification: %s\n") + call pargstr (token) + return + } + + call gargstr (line, SZ_LINE) + + # Prompt user to set cursor + + call eprintf ("Set cursor to desired location, then press any button\n") + button = cv_wtbut() + + # Set up kernel for write + if (frames[1] != ERR) { + cnum = frames[1] + call cv_iset (frames) + } else { + cnum = 16 # SORRY, is IIS specific - we should do better + call cv_gset (colors) + } + call cv_rcur (cnum, x, y) + + size = clgetr("textsize") + ip = 1 + while (IS_WHITE(line[ip])) + ip = ip + 1 + call cvtext (x, y, line[ip], size) +end diff --git a/pkg/images/tv/iis/src/window.x b/pkg/images/tv/iis/src/window.x new file mode 100644 index 00000000..e3523a90 --- /dev/null +++ b/pkg/images/tv/iis/src/window.x @@ -0,0 +1,181 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# WINDOW -- window the display. + +procedure window() + +char token[SZ_LINE] +int tok, cnum +short frames[IDS_MAXIMPL+2] # frames, graphics, EOD +short colors[IDS_MAXGCOLOR] +real x, y +real xold, yold +int device, button, cv_rdbut() +short wdata[16] +int n, first, last +real istart, iend, slope + +include "cv.com" + +begin + # Find out if want to change output tables + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (( tok == TOK_IDENTIFIER) && (token[1] == 'o')) { + device = IDS_OUTPUT_LUT + slope = 4.0 # Device dependent !! + } else { + device = IDS_FRAME_LUT + slope = 1.0 + # reset input pointers; same as having pushed back token + call reset_scan + call gargtok (tok, token, SZ_LINE) + } + + # Default to all frames, all colors + frames[1] = IDS_EOD + colors[1] = IDS_EOD + + # which frames to window + + repeat { + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (tok == TOK_IDENTIFIER) { + if (token[1] == 'f') { + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (token[1] == 'c') { + call cv_color (token[2], colors) + if (colors[1] == ERR) + return + } else { + call eprintf ("Unknown window argument: %s\n") + call pargstr (token) + return + } + } else if (tok == TOK_NUMBER) { + call cv_frame (token[1], frames) + if (frames[1] == ERR) + return + } else if (tok != TOK_NEWLINE) { + call eprintf ("Unexpected window input: %s\n") + call pargstr (token) + return + } + } until ( tok == TOK_NEWLINE) + + # rememeber current cursor postion + + cnum = 0 + call cv_rcur (cnum, xold, yold) + + # Now set up loop to window display; we need to read back + # display but cannot, so for now, use "common" variables + # If first time, use defaults. + + if (cv_xwinc == -1) { + if (slope == 1.0) { + cv_xwinc = 0.25 + cv_ywinc = .75 + } else { + cv_xwinc = .0625 + cv_ywinc = .9375 + } + } + call cv_scraw (cv_xwinc, cv_ywinc) + + button = cv_rdbut() # clear buttons by reading them + call eprintf ("Press any button when done\n") + + # The mapping equation is table value = 0.25 + y * (i-x) + # where i runs from 0 to 1.0, x ranges from 0. to 1.0 and y + # from 0 to large. + + repeat { + call cv_rcraw (cv_xwinc, cv_ywinc) + x = cv_xwinc + y = (cv_ywinc - 0.5) * 4 + # Keep y from equalling 2 or -2 : + if (y >= 2.) + y = 1.99 + else if ( y <= -2.0) + y = -1.99 + if (y > 1.) + y = 1. / (2. - y) + else if (y < -1.) + y = -1. / (2. + y) + + if ( y == 0.0) { + iend = 1.0 + istart = 0.0 + first = 0 + last = GKI_MAXNDC + } else if ( y > 0.) { + istart = x - 0.25/y + iend = 1.0/y + istart + first = 0 + last = GKI_MAXNDC + } else { + iend = x - 0.25/y + istart = 1.0/y + iend + first = GKI_MAXNDC + last = 0 + } + if (istart < 0.) + istart = 0. + if (iend > 1.0) + iend = 1.0 + if (istart > 1.0) + istart = 1.0 + if (iend < istart) + iend = istart + wdata[1] = 0 + if ( istart > 0.) { + wdata[2] = first + wdata[3] = istart * GKI_MAXNDC + wdata[4] = first + n = 5 + } else { + wdata[2] = (0.25 -x*y) * GKI_MAXNDC + n = 3 + } + wdata[n] = iend * GKI_MAXNDC + if ( iend < 1.0) { + # In this case, we reach max/min y value before end of table, so + # extend it horizontally to end + wdata[n+1] = last + wdata[n+2] = GKI_MAXNDC + wdata[n+3] = last + n = n + 3 + } else { + wdata[n+1] = (0.25 + y * (1.0 - x)) * GKI_MAXNDC + n = n + 1 + } + call cvwlut (device, frames, colors, wdata, n) + button = cv_rdbut() + } until (button > 0) + + # Restore old cursor position + call cv_rcur (cnum, xold, yold) + + # Tell the user what final mapping was + call printf ("window: from (%5.3f,%5.3f) to (%5.3f,%5.3f)\n") + call pargr (istart) + if (istart > 0.) + call pargr (real(first)/GKI_MAXNDC) + else + call pargr (real(wdata[2])/GKI_MAXNDC) + call pargr (iend) + if (iend < 1.0) + call pargr (real(last)/GKI_MAXNDC) + else + call pargr (real(wdata[n])/GKI_MAXNDC) + +end diff --git a/pkg/images/tv/iis/src/zoom.x b/pkg/images/tv/iis/src/zoom.x new file mode 100644 index 00000000..c7e7bff7 --- /dev/null +++ b/pkg/images/tv/iis/src/zoom.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../lib/ids.h" + +# ZOOM -- zoom, then pan, the display. If zoom power == 1, then +# don't bother panning. + +procedure zoom() + +char token[SZ_LINE] +int tok, count, power, cnum +short frames[IDS_MAXIMPL+2] # frames, graphics, EOD +real x, y +int ctoi, ip + +include "cv.com" + +begin + # get power for zoom + + call gargtok (tok, token, SZ_LINE) + if (tok != TOK_NUMBER) { + call eprintf ("Bad zoom power: %s\n") + call pargstr (token) + return + } + ip = 1 + count = ctoi(token, ip, power) + + # which frames to zoom + + frames[1] = IDS_EOD # default all frames + call gargtok (tok, token, SZ_LINE) + call strlwr (token) + if (token[1] == 'f') { + call cv_frame (token[2], frames) + if (frames[1] == ERR) + return + } else if (tok == TOK_NUMBER) { + call cv_frame (token[1], frames) + if (frames[1] == ERR) + return + } else { + call eprintf ("Unexpected input: %s\n") + call pargstr (token) + return + } + + # where to zoom ... find which frame to read cursor position from + + cnum = frames[1] + if (cnum == IDS_EOD) + cnum = 0 + call cv_rcur (cnum, x, y) + call cvzoom (frames, power, x, y) + call pansub (frames) +end diff --git a/pkg/images/tv/iis/src/zscale.x b/pkg/images/tv/iis/src/zscale.x new file mode 100644 index 00000000..bfb0b116 --- /dev/null +++ b/pkg/images/tv/iis/src/zscale.x @@ -0,0 +1,457 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +.help zscale +.nf ___________________________________________________________________________ +ZSCALE -- Compute the optimal Z1, Z2 (range of greyscale values to be +displayed) of an image. For efficiency a statistical subsample of an image +is used. The pixel sample evenly subsamples the image in x and y. The entire +image is used if the number of pixels in the image is smaller than the desired +sample. + +The sample is accumulated in a buffer and sorted by greyscale value. +The median value is the central value of the sorted array. The slope of a +straight line fitted to the sorted sample is a measure of the standard +deviation of the sample about the median value. Our algorithm is to sort +the sample and perform an iterative fit of a straight line to the sample, +using pixel rejection to omit gross deviants near the endpoints. The fitted +straight line is the transfer function used to map image Z into display Z. +If more than half the pixels are rejected the full range is used. The slope +of the fitted line is divided by the user-supplied contrast factor and the +final Z1 and Z2 are computed, taking the origin of the fitted line at the +median value. +.endhelp ______________________________________________________________________ + +define MIN_NPIXELS 5 # smallest permissible sample +define MAX_REJECT 0.5 # max frac. of pixels to be rejected +define GOOD_PIXEL 0 # use pixel in fit +define BAD_PIXEL 1 # ignore pixel in all computations +define REJECT_PIXEL 2 # reject pixel after a bit +define KREJ 2.5 # k-sigma pixel rejection factor +define MAX_ITERATIONS 5 # maximum number of fitline iterations + + +# ZSCALE -- Sample the image and compute Z1 and Z2. + +procedure zscale (im, z1, z2, contrast, optimal_sample_size, len_stdline) + +pointer im # image to be sampled +real z1, z2 # output min and max greyscale values +real contrast # adj. to slope of transfer function +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +int npix, minpix, ngoodpix, center_pixel, ngrow +real zmin, zmax, median +real zstart, zslope +pointer sample, left +int zsc_sample_image(), zsc_fit_line() + +begin + # Subsample the image. + npix = zsc_sample_image (im, sample, optimal_sample_size, len_stdline) + center_pixel = max (1, (npix + 1) / 2) + + # Sort the sample, compute the minimum, maximum, and median pixel + # values. + + call asrtr (Memr[sample], Memr[sample], npix) + zmin = Memr[sample] + zmax = Memr[sample+npix-1] + + # The median value is the average of the two central values if there + # are an even number of pixels in the sample. + + left = sample + center_pixel - 1 + if (mod (npix, 2) == 1 || center_pixel >= npix) + median = Memr[left] + else + median = (Memr[left] + Memr[left+1]) / 2 + + # Fit a line to the sorted sample vector. If more than half of the + # pixels in the sample are rejected give up and return the full range. + # If the user-supplied contrast factor is not 1.0 adjust the scale + # accordingly and compute Z1 and Z2, the y intercepts at indices 1 and + # npix. + + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + ngrow = max (1, nint (npix * .01)) + ngoodpix = zsc_fit_line (Memr[sample], npix, zstart, zslope, + KREJ, ngrow, MAX_ITERATIONS) + + if (ngoodpix < minpix) { + z1 = zmin + z2 = zmax + } else { + if (contrast > 0) + zslope = zslope / contrast + z1 = max (zmin, median - (center_pixel - 1) * zslope) + z2 = min (zmax, median + (npix - center_pixel) * zslope) + } + + call mfree (sample, TY_REAL) +end + + +# ZSC_SAMPLE_IMAGE -- Extract an evenly gridded subsample of the pixels from +# a two-dimensional image into a one-dimensional vector. + +int procedure zsc_sample_image (im, sample, optimal_sample_size, len_stdline) + +pointer im # image to be sampled +pointer sample # output vector containing the sample +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +int ncols, nlines, col_step, line_step, maxpix, line +int opt_npix_per_line, npix_per_line +int opt_nlines_in_sample, min_nlines_in_sample, max_nlines_in_sample +pointer op +pointer imgl2r() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Compute the number of pixels each line will contribute to the sample, + # and the subsampling step size for a line. The sampling grid must + # span the whole line on a uniform grid. + + opt_npix_per_line = min (ncols, len_stdline) + col_step = (ncols + opt_npix_per_line-1) / opt_npix_per_line + npix_per_line = (ncols + col_step-1) / col_step + + # Compute the number of lines to sample and the spacing between lines. + # We must ensure that the image is adequately sampled despite its + # size, hence there is a lower limit on the number of lines in the + # sample. We also want to minimize the number of lines accessed when + # accessing a large image, because each disk seek and read is expensive. + # The number of lines extracted will be roughly the sample size divided + # by len_stdline, possibly more if the lines are very short. + + min_nlines_in_sample = max (1, optimal_sample_size / len_stdline) + opt_nlines_in_sample = max(min_nlines_in_sample, min(nlines, + (optimal_sample_size + npix_per_line-1) / npix_per_line)) + line_step = max (1, nlines / (opt_nlines_in_sample)) + max_nlines_in_sample = (nlines + line_step-1) / line_step + + # Allocate space for the output vector. Buffer must be freed by our + # caller. + + maxpix = npix_per_line * max_nlines_in_sample + call malloc (sample, maxpix, TY_REAL) + +# call eprintf ("sample: x[%d:%d:%d] y[%d:%d:%d]\n") +# call pargi(1);call pargi(ncols); call pargi(col_step) +# call pargi((line_step+1)/2); call pargi(nlines); call pargi(line_step) + + # Extract the vector. + op = sample + do line = (line_step + 1) / 2, nlines, line_step { + call zsc_subsample (Memr[imgl2r(im,line)], Memr[op], + npix_per_line, col_step) + op = op + npix_per_line + if (op - sample + npix_per_line > maxpix) + break + } + + return (op - sample) +end + + +# ZSC_SUBSAMPLE -- Subsample an image line. Extract the first pixel and +# every "step"th pixel thereafter for a total of npix pixels. + +procedure zsc_subsample (a, b, npix, step) + +real a[ARB] +real b[npix] +int npix, step +int ip, i + +begin + if (step <= 1) + call amovr (a, b, npix) + else { + ip = 1 + do i = 1, npix { + b[i] = a[ip] + ip = ip + step + } + } +end + + +# ZSC_FIT_LINE -- Fit a straight line to a data array of type real. This is +# an iterative fitting algorithm, wherein points further than ksigma from the +# current fit are excluded from the next fit. Convergence occurs when the +# next iteration does not decrease the number of pixels in the fit, or when +# there are no pixels left. The number of pixels left after pixel rejection +# is returned as the function value. + +int procedure zsc_fit_line (data, npix, zstart, zslope, krej, ngrow, maxiter) + +real data[npix] # data to be fitted +int npix # number of pixels before rejection +real zstart # Z-value of pixel data[1] (output) +real zslope # dz/pixel (output) +real krej # k-sigma pixel rejection factor +int ngrow # number of pixels of growing +int maxiter # max iterations + +int i, ngoodpix, last_ngoodpix, minpix, niter +real xscale, z0, dz, x, z, mean, sigma, threshold +double sumxsqr, sumxz, sumz, sumx, rowrat +pointer sp, flat, badpix, normx +int zsc_reject_pixels(), zsc_compute_sigma() + +begin + call smark (sp) + + if (npix <= 0) + return (0) + else if (npix == 1) { + zstart = data[1] + zslope = 0.0 + return (1) + } else + xscale = 2.0 / (npix - 1) + + # Allocate a buffer for data minus fitted curve, another for the + # normalized X values, and another to flag rejected pixels. + + call salloc (flat, npix, TY_REAL) + call salloc (normx, npix, TY_REAL) + call salloc (badpix, npix, TY_SHORT) + call aclrs (Mems[badpix], npix) + + # Compute normalized X vector. The data X values [1:npix] are + # normalized to the range [-1:1]. This diagonalizes the lsq matrix + # and reduces its condition number. + + do i = 0, npix - 1 + Memr[normx+i] = i * xscale - 1.0 + + # Fit a line with no pixel rejection. Accumulate the elements of the + # matrix and data vector. The matrix M is diagonal with + # M[1,1] = sum x**2 and M[2,2] = ngoodpix. The data vector is + # DV[1] = sum (data[i] * x[i]) and DV[2] = sum (data[i]). + + sumxsqr = 0 + sumxz = 0 + sumx = 0 + sumz = 0 + + do i = 1, npix { + x = Memr[normx+i-1] + z = data[i] + sumxsqr = sumxsqr + (x ** 2) + sumxz = sumxz + z * x + sumz = sumz + z + } +# call eprintf ("\t%10g %10g %10g\n") +# call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz) + + # Solve for the coefficients of the fitted line. + z0 = sumz / npix + dz = sumxz / sumxsqr + +# call eprintf ("fit: z0=%g, dz=%g\n") +# call pargr(z0); call pargr(dz) + + # Iterate, fitting a new line in each iteration. Compute the flattened + # data vector and the sigma of the flat vector. Compute the lower and + # upper k-sigma pixel rejection thresholds. Run down the flat array + # and detect pixels to be rejected from the fit. Reject pixels from + # the fit by subtracting their contributions from the matrix sums and + # marking the pixel as rejected. + + ngoodpix = npix + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + + for (niter=1; niter <= maxiter; niter=niter+1) { + last_ngoodpix = ngoodpix + + # Subtract the fitted line from the data array. + call zsc_flatten_data (data, Memr[flat], Memr[normx], npix, z0, dz) + + # Compute the k-sigma rejection threshold. In principle this + # could be more efficiently computed using the matrix sums + # accumulated when the line was fitted, but there are problems with + # numerical stability with that approach. + + ngoodpix = zsc_compute_sigma (Memr[flat], Mems[badpix], npix, + mean, sigma) + threshold = sigma * krej + + # Detect and reject pixels further than ksigma from the fitted + # line. + ngoodpix = zsc_reject_pixels (data, Memr[flat], Memr[normx], + Mems[badpix], npix, sumxsqr, sumxz, sumx, sumz, threshold, + ngrow) + + # Solve for the coefficients of the fitted line. Note that after + # pixel rejection the sum of the X values need no longer be zero. + + if (ngoodpix > 0) { + rowrat = sumx / sumxsqr + z0 = (sumz - rowrat * sumxz) / (ngoodpix - rowrat * sumx) + dz = (sumxz - z0 * sumx) / sumxsqr + } + +# call eprintf ("fit: z0=%g, dz=%g, threshold=%g, npix=%d\n") +# call pargr(z0); call pargr(dz); call pargr(threshold); call pargi(ngoodpix) + + if (ngoodpix >= last_ngoodpix || ngoodpix < minpix) + break + } + + # Transform the line coefficients back to the X range [1:npix]. + zstart = z0 - dz + zslope = dz * xscale + + call sfree (sp) + return (ngoodpix) +end + + +# ZSC_FLATTEN_DATA -- Compute and subtract the fitted line from the data array, +# returned the flattened data in FLAT. + +procedure zsc_flatten_data (data, flat, x, npix, z0, dz) + +real data[npix] # raw data array +real flat[npix] # flattened data (output) +real x[npix] # x value of each pixel +int npix # number of pixels +real z0, dz # z-intercept, dz/dx of fitted line +int i + +begin + do i = 1, npix + flat[i] = data[i] - (x[i] * dz + z0) +end + + +# ZSC_COMPUTE_SIGMA -- Compute the root mean square deviation from the +# mean of a flattened array. Ignore rejected pixels. + +int procedure zsc_compute_sigma (a, badpix, npix, mean, sigma) + +real a[npix] # flattened data array +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +real mean, sigma # (output) + +real pixval +int i, ngoodpix +double sum, sumsq, temp + +begin + sum = 0 + sumsq = 0 + ngoodpix = 0 + + # Accumulate sum and sum of squares. + do i = 1, npix + if (badpix[i] == GOOD_PIXEL) { + pixval = a[i] + ngoodpix = ngoodpix + 1 + sum = sum + pixval + sumsq = sumsq + pixval ** 2 + } + + # Compute mean and sigma. + switch (ngoodpix) { + case 0: + mean = INDEF + sigma = INDEF + case 1: + mean = sum + sigma = INDEF + default: + mean = sum / ngoodpix + temp = sumsq / (ngoodpix - 1) - sum**2 / (ngoodpix * (ngoodpix - 1)) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngoodpix) +end + + +# ZSC_REJECT_PIXELS -- Detect and reject pixels more than "threshold" greyscale +# units from the fitted line. The residuals about the fitted line are given +# by the "flat" array, while the raw data is in "data". Each time a pixel +# is rejected subtract its contributions from the matrix sums and flag the +# pixel as rejected. When a pixel is rejected reject its neighbors out to +# a specified radius as well. This speeds up convergence considerably and +# produces a more stringent rejection criteria which takes advantage of the +# fact that bad pixels tend to be clumped. The number of pixels left in the +# fit is returned as the function value. + +int procedure zsc_reject_pixels (data, flat, normx, badpix, npix, + sumxsqr, sumxz, sumx, sumz, threshold, ngrow) + +real data[npix] # raw data array +real flat[npix] # flattened data array +real normx[npix] # normalized x values of pixels +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +double sumxsqr,sumxz,sumx,sumz # matrix sums +real threshold # threshold for pixel rejection +int ngrow # number of pixels of growing + +int ngoodpix, i, j +real residual, lcut, hcut +double x, z + +begin + ngoodpix = npix + lcut = -threshold + hcut = threshold + + do i = 1, npix + if (badpix[i] == BAD_PIXEL) + ngoodpix = ngoodpix - 1 + else { + residual = flat[i] + if (residual < lcut || residual > hcut) { + # Reject the pixel and its neighbors out to the growing + # radius. We must be careful how we do this to avoid + # directional effects. Do not turn off thresholding on + # pixels in the forward direction; mark them for rejection + # but do not reject until they have been thresholded. + # If this is not done growing will not be symmetric. + + do j = max(1,i-ngrow), min(npix,i+ngrow) { +#call eprintf ("\t\t%d->%d\tcheck\n");call pargi(j); call pargs(badpix[j]) + if (badpix[j] != BAD_PIXEL) { + if (j <= i) { + x = normx[j] + z = data[j] +#call eprintf ("\treject [%d:%6g]=%6g sum[xsqr,xz,z]\n") +#call pargi(j); call pargd(x); call pargd(z) +#call eprintf ("\t%10g %10g %10g\n") +#call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz) + sumxsqr = sumxsqr - (x ** 2) + sumxz = sumxz - z * x + sumx = sumx - x + sumz = sumz - z +#call eprintf ("\t%10g %10g %10g\n") +#call pargd(sumxsqr); call pargd(sumxz); call pargd(sumz) + badpix[j] = BAD_PIXEL + ngoodpix = ngoodpix - 1 + } else + badpix[j] = REJECT_PIXEL +#call eprintf ("\t\t%d->%d\tset\n");call pargi(j); call pargs(badpix[j]) + } + } + } + } + + return (ngoodpix) +end diff --git a/pkg/images/tv/iis/window.cl b/pkg/images/tv/iis/window.cl new file mode 100644 index 00000000..25f00c65 --- /dev/null +++ b/pkg/images/tv/iis/window.cl @@ -0,0 +1,5 @@ +#{ WINDOW -- Adjust the lookup tables for the current frame. + +{ + _dcontrol (type="frame", window+) +} diff --git a/pkg/images/tv/iis/x_iis.x b/pkg/images/tv/iis/x_iis.x new file mode 100644 index 00000000..06813f75 --- /dev/null +++ b/pkg/images/tv/iis/x_iis.x @@ -0,0 +1,7 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Driver for image control + +task cv = t_cv, + cvl = t_load + #giis = t_giis diff --git a/pkg/images/tv/iis/zoom.cl b/pkg/images/tv/iis/zoom.cl new file mode 100644 index 00000000..9aa48959 --- /dev/null +++ b/pkg/images/tv/iis/zoom.cl @@ -0,0 +1,11 @@ +#{ ZOOM -- Zoom in on a portion of the display. + +# zoom_factor,i,a,2,1,4,factor by which image scale is to be expanded +# window,b,h,no,,,window enlarged image + +{ + if (window) + _dcontrol (zoom=zoom_factor, roam=yes, window=yes) + else + _dcontrol (zoom=zoom_factor, roam=yes) +} diff --git a/pkg/images/tv/iis/zoom.par b/pkg/images/tv/iis/zoom.par new file mode 100644 index 00000000..849c3439 --- /dev/null +++ b/pkg/images/tv/iis/zoom.par @@ -0,0 +1,2 @@ +zoom_factor,i,a,2,1,4,factor by which image scale is to be expanded +window,b,h,no,,,window enlarged image diff --git a/pkg/images/tv/imedit.par b/pkg/images/tv/imedit.par new file mode 100644 index 00000000..f23ea1c6 --- /dev/null +++ b/pkg/images/tv/imedit.par @@ -0,0 +1,24 @@ +input,s,a,,,,Images to be edited +output,s,a,,,,Output images +cursor,*imcur,h,"",,,Cursor input +logfile,s,h,"",,,Logfile for record of cursor commands +display,b,h,yes,,,Display images? +autodisplay,b,h,yes,,,Automatic image display? +autosurface,b,h,no,,,Automatic surface plots? +aperture,s,h,"circular","|circular|square|",,Aperture type +radius,r,h,2.,,,Substitution radius +search,r,h,2.,,,Search radius +minvalue,r,h,INDEF,,,Minimum value to modify +maxvalue,r,h,INDEF,,,Maximum value to modify +buffer,r,h,1.,0.,,Background buffer width +width,r,h,2.,1.,,Background width +xorder,i,h,2,0,,Background x order +yorder,i,h,2,0,,Background y order +value,r,h,0.,,,Constant value substitution +sigma,r,h,INDEF,,,Added noise sigma +angh,r,h, -33.,,,Horizontal viewing angle (degrees) +angv,r,h,25.,,,Vertical viewing angle (degrees) +command,s,h,"display $image 1 erase=$erase fill=yes order=0 >& dev$null",,,Display command +graphics,s,h,"stdgraph",,,Graphics device +default,s,h,"b",,,Default option for x-y input +fixpix,b,h,no,,,Fixpix style input? diff --git a/pkg/images/tv/imedit/bpmedit.cl b/pkg/images/tv/imedit/bpmedit.cl new file mode 100644 index 00000000..01d5f7aa --- /dev/null +++ b/pkg/images/tv/imedit/bpmedit.cl @@ -0,0 +1,69 @@ +# BPMEDIT -- Edit BPM masks. + +procedure bpmedit (images) + +string images {prompt="List of images"} +string bpmkey = "BPM" {prompt="Keyword with mask name"} +int frame = 1 {prompt="Display frame with mask overlay"} +int refframe = 2 {prompt="Display frame without mask overlay"} +string command = "display $image $frame over=$mask erase=$erase ocol='1-10=red,green' fill-" {prompt="Display command"} +bool display = yes {prompt="Interactive display?"} +string cursor = "" {prompt="Cursor input"} + +struct *fd + +begin + int i1 + file im, bpm, temp + struct dispcmd + + set imedit_help = "tv$imedit/bpmedit.key" + + temp = mktemp ("tmp$iraf") + + sections (images, option="fullname", > temp) + + fd = temp + while (fscan (fd, im) != EOF) { + bpm = ""; hselect (im, bpmkey, yes) | scan (bpm) + if (bpm == "") { + printf ("WARNING: No %s keyword (%s)\n", bpmkey, im) + next + } + if (imaccess(bpm)==NO) { + printf ("WARNING: Can't access mask (%s)\n", bpm) + next + } + + if (display) { + # Override certain display parameters. + display.bpdisplay="none" + display.fill = no + + # Set display command. + dispcmd = command + i1 = strstr ("$image", dispcmd) + if (i1 > 0) + dispcmd = substr (dispcmd, 1, i1-1) // im // + substr (dispcmd, i1+6, 1000) + i1 = strstr ("$frame", dispcmd) + if (i1 > 0) + dispcmd = substr (dispcmd, 1, i1-1) // frame // + substr (dispcmd, i1+6, 1000) + i1 = strstr ("$mask", dispcmd) + if (i1 > 0) + dispcmd = substr (dispcmd, 1, i1-1) // "$image" // + substr (dispcmd, i1+5, 1000) + i1 = strstr (">", dispcmd) + if (i1 == 0) + dispcmd += " >& dev$null" + + display (im, refframe, over="", >& "dev$null") + imedit (bpm, "", command=dispcmd, display=display, + cursor=cursor, search=0) + } else + imedit (bpm, "", command=dispcmd, display=display, + cursor=cursor, search=0) + } + fd = ""; delete (temp, verify-) +end diff --git a/pkg/images/tv/imedit/bpmedit.key b/pkg/images/tv/imedit/bpmedit.key new file mode 100644 index 00000000..0d660732 --- /dev/null +++ b/pkg/images/tv/imedit/bpmedit.key @@ -0,0 +1,51 @@ + BPMEDIT CURSOR KEYSTROKE COMMANDS + +The following are the useful commands for BPMEDIT. Note all +the commands for IMEDIT are available but only those shown +here should be used for editing pixel masks. + + ? Print help + : Colon commands (see below) + i Initialize (start over without saving changes) + q Quit and save changes + r Redraw image display + + Increase radius by one + - Decrease radius by one + I Interrupt task immediately + Q Quit without saving changes + +The following editing options are available. Rectangular +and vector regions are specified with two positions and +aperture regions are specified by one position. The current +aperture type (circular or square) is used in the latter +case. All the following substitute the new value set for +the "value" parameter (see :value). Some replace all pixels +within the mask that have the same pixel value as the value +at the cursor position. + + d Set rectangle to "value" + e Set aperture to "value" + u Undo last change (see also 'i', 'j', and 'k') + v Set vector to "value" + = Replace pixels = to "cursor value" to "value" + < Replace pixels < or = to "cursor value" to "value" + > Replace pixels > than or = to "cursor value" to "value" + + + BPMEDIT COLON COMMANDS + +The colon either print the current value of a parameter when +there is no value or set the parameter to the specified +value. + +aperture [type] Aperture type (circular|square) +autodisplay [yes|no] Automatic image display? +command [string] Display command +display [yes|no] Display image? +eparam Edit parameters +radius [value] Aperture radius +value [value] Constant substitution value +minvalue [value] Minimum value for modification (INDEF=minimum) +maxvalue [value] Maximum value for modification (INDEF=maximum) +write [name] Write changes to name + diff --git a/pkg/images/tv/imedit/epbackground.x b/pkg/images/tv/imedit/epbackground.x new file mode 100644 index 00000000..339de946 --- /dev/null +++ b/pkg/images/tv/imedit/epbackground.x @@ -0,0 +1,71 @@ +include "epix.h" + +# EP_BACKGROUND -- Replace aperture by background values. +# The aperture is first centered. The background is determined from a +# annulus buffered from the aperture and of a specified width. The +# background is obtained by fitting a surface. Noise may be added +# using a gaussian or by histogram sampling. + +procedure ep_background (ep, ap, xa, ya, xb, yb) + +pointer ep # EPIX structure +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates + +int i, x1, x2, y1, y2 +pointer mask, x, y, w, gs + +begin + i = max (5., + abs (EP_SEARCH(ep)) + EP_BUFFER(ep) + EP_WIDTH(ep) + 1) + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, yb) - i + y2 = max (ya, yb) + i + call ep_gdata (ep, x1, x2, y1, y2) + if (EP_OUTDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + call malloc (x, EP_NPTS(ep), TY_REAL) + call malloc (y, EP_NPTS(ep), TY_REAL) + call malloc (w, EP_NPTS(ep), TY_REAL) + + call ep_search (ep, Memr[EP_OUTDATA(ep)], EP_NX(ep), EP_NY(ep), + ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + call ep_gsfit (ep, Memr[EP_OUTDATA(ep)], Memi[mask], Memr[x], + Memr[y], Memr[w], EP_NX(ep), EP_NY(ep), gs) + call ep_bg (Memr[EP_OUTDATA(ep)], Memi[mask], + Memr[x], Memr[y], EP_NPTS(ep), gs) + call ep_noise (EP_SIGMA(ep), Memr[EP_OUTDATA(ep)], + Memi[mask], Memr[x], Memr[y], EP_NPTS(ep), gs) + + call mfree (mask, TY_INT) + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (w, TY_REAL) + call gsfree (gs) + } +end + + +# EP_BG -- Replace aperture pixels by the background surface fit values. + +procedure ep_bg (data, mask, x, y, npts, gs) + +real data[npts] # Data subraster +int mask[npts] # Mask subraster +real x[npts], y[npts] # Coordinates +int npts # Number of points +pointer gs # Surface pointer + +int i +real gseval() + +begin + if (gs == NULL) + return + + do i = 1, npts + if (mask[i] == 1) + data[i] = gseval (gs, x[i], y[i]) +end diff --git a/pkg/images/tv/imedit/epcol.x b/pkg/images/tv/imedit/epcol.x new file mode 100644 index 00000000..e71d5e47 --- /dev/null +++ b/pkg/images/tv/imedit/epcol.x @@ -0,0 +1,80 @@ +include "epix.h" + +# EP_COL -- Replace aperture by column interpolation from background annulus. +# The aperture is first centered. The interpolation is across columns +# from the nearest pixel in the background annulus. Gaussian Noise may +# be added. + +procedure ep_col (ep, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates + +int i, x1, x2, y1, y2 +pointer mask, gs + +begin + i = abs (EP_SEARCH(ep)) + EP_BUFFER(ep) + 1 + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, yb) + y2 = max (ya, yb) + call ep_gdata (ep, x1, x2, y1, y2) + if (EP_OUTDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + + call ep_search (ep, Memr[EP_OUTDATA(ep)], EP_NX(ep), + EP_NY(ep), ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + call ep_col1 (Memr[EP_OUTDATA(ep)], Memi[mask], EP_NX(ep), + EP_NY(ep)) + if (!IS_INDEF (EP_SIGMA(ep))) + call ep_noise (EP_SIGMA(ep), Memr[EP_OUTDATA(ep)], + Memi[mask], Memr[EP_OUTDATA(ep)], Memr[EP_OUTDATA(ep)], + EP_NPTS(ep), gs) + + call mfree (mask, TY_INT) + } +end + + +# EP_COL1 -- Do column interpolation. + +procedure ep_col1 (data, mask, nx, ny) + +real data[nx,ny] # Data subraster +int mask[nx,ny] # Mask subraster +int nx, ny # Number of points + +int i, j, xa, xb, xc, xd +real a, b + +begin + do i = 1, ny { + for (xa=1; xa<=nx && mask[xa,i]!=1; xa=xa+1) + ; + if (xa > nx) + next + for (xb=nx; xb>xa && mask[xb,i]!=1; xb=xb-1) + ; + for (xc=xa; xc>=1 && mask[xc,i]!=2; xc=xc-1) + ; + for (xd=xb; xd<=nx && mask[xd,i]!=2; xd=xd+1) + ; + if (xc < 1 && xd > nx) + next + else if (xc < 1) + do j = xa, xb + data[j,i] = data[xd,i] + else if (xd > nx) + do j = xa, xb + data[j,i] = data[xc,i] + else { + a = data[xc,i] + b = (data[xd,i] - a) / (xd - xc) + do j = xa, xb + data[j,i] = a + b * (j - xc) + } + } +end diff --git a/pkg/images/tv/imedit/epcolon.x b/pkg/images/tv/imedit/epcolon.x new file mode 100644 index 00000000..51765889 --- /dev/null +++ b/pkg/images/tv/imedit/epcolon.x @@ -0,0 +1,335 @@ +include "epix.h" + +# List of colon commands. +define CMDS "|angh|angv|aperture|autodisplay|autosurface|buffer|command|\ + |display|eparam|graphics|input|output|radius|search|sigma|\ + |value|minvalue|maxvalue|width|write|xorder|yorder|" + +define ANGH 1 # Horizontal viewing angle +define ANGV 2 # Vertical viewing angle +define APERTURE 3 # Aperture type +define AUTODISPLAY 4 # Automatic display? +define AUTOSURFACE 5 # Automatic surface graph? +define BUFFER 6 # Background buffer width +define COMMAND 7 # Display command +define DISPLAY 9 # Display image? +define EPARAM 10 # Eparam +define GRAPHICS 11 # Graphics device +define INPUT 12 # Input image +define OUTPUT 13 # Output image +define RADIUS 14 # Aperture radius +define SEARCH 15 # Search radius +define SIGMA 16 # Noise sigma +define VALUE 18 # Constant substitution value +define MINVALUE 19 # Minimum value for replacement +define MAXVALUE 20 # Maximum value for replacement +define WIDTH 21 # Background width +define WRITE 22 # Write output +define XORDER 23 # X order +define YORDER 24 # Y order + +# EP_COLON -- Respond to colon commands. +# The changed parameters are written to the parameter file and +# to the optional log file. + +procedure ep_colon (ep, cmdstr, newimage) + +pointer ep # EPIX structure +char cmdstr[ARB] # Colon command +int newimage # New image? + +int ival, ncmd +real rval +bool bval +pointer sp, cmd + +bool strne() +int nscan(), strdic(), btoi(), imaccess() +pointer immap() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Scan the command string and get the first word. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + + switch (ncmd) { + case ANGH: + call gargr (rval) + if (nscan() == 1) { + call printf ("angh %g\n") + call pargr (EP_ANGH(ep)) + } else { + EP_ANGH(ep) = rval + call clputr ("angh", EP_ANGH(ep)) + } + case ANGV: + call gargr (rval) + if (nscan() == 1) { + call printf ("angv %g\n") + call pargr (EP_ANGV(ep)) + } else { + EP_ANGV(ep) = rval + call clputr ("angv", EP_ANGV(ep)) + } + case APERTURE: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call printf ("aperture %s\n") + switch (EP_APERTURE(ep)) { + case APCIRCULAR: + call pargstr ("circular") + case APSQUARE: + call pargstr ("square") + } + } else { + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, APTYPES) + if (ncmd > 0) { + EP_APERTURE(ep) = ncmd + call clpstr ("aperture", Memc[cmd]) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":aperture %s\n") + call pargstr (Memc[cmd]) + } + } else + call printf ("Unknown aperture type\n") + } + case AUTODISPLAY: + call gargb (bval) + if (nscan() == 1) { + if (EP_AUTODISPLAY(ep) == YES) + call printf ("autodisplay yes\n") + else + call printf ("autodisplay no\n") + } else { + EP_AUTODISPLAY(ep) = btoi (bval) + call clputb ("autodisplay", bval) + } + case AUTOSURFACE: + call gargb (bval) + if (nscan() == 1) { + if (EP_AUTOSURFACE(ep) == YES) + call printf ("autosurface yes\n") + else + call printf ("autosurface no\n") + } else { + EP_AUTOSURFACE(ep) = btoi (bval) + call clputb ("autosurface", bval) + } + case BUFFER: + call gargr (rval) + if (nscan() == 1) { + call printf ("buffer %g\n") + call pargr (EP_BUFFER(ep)) + } else { + EP_BUFFER(ep) = rval + call clputr ("buffer", EP_BUFFER(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":buffer %g\n") + call pargr (EP_BUFFER(ep)) + } + } + case COMMAND: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call printf ("command %s\n") + call pargstr (EP_COMMAND(ep)) + } else { + call strcpy (Memc[cmd], EP_COMMAND(ep), EP_SZLINE) + call gargstr (Memc[cmd], SZ_FNAME) + call strcat (Memc[cmd], EP_COMMAND(ep), EP_SZFNAME) + call clpstr ("command", EP_COMMAND(ep)) + } + case DISPLAY: + call gargb (bval) + if (nscan() == 1) { + if (EP_DISPLAY(ep) == YES) + call printf ("display yes\n") + else + call printf ("display no\n") + } else { + EP_DISPLAY(ep) = btoi (bval) + call clputb ("display", bval) + } + case EPARAM: + call clcmdw ("eparam imedit") + call ep_setpars (ep) + case GRAPHICS: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call printf ("graphics %s\n") + call pargstr (EP_GRAPHICS(ep)) + } else { + call strcpy (Memc[cmd], EP_GRAPHICS(ep), EP_SZFNAME) + call clpstr ("graphics", EP_GRAPHICS(ep)) + } + case INPUT: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call printf ("input %s\n") + call pargstr (EP_INPUT(ep)) + } else if (strne (Memc[cmd], EP_INPUT(ep))) { + call strcpy (Memc[cmd], EP_INPUT(ep), SZ_LINE) + newimage = YES + } + case OUTPUT: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call printf ("output %s\n") + call pargstr (EP_OUTPUT(ep)) + } else if (strne (Memc[cmd], EP_INPUT(ep))) { + if (imaccess (Memc[cmd], READ_ONLY) == YES) { + call eprintf ("%s: Output image %s exists\n") + call pargstr (EP_INPUT(ep)) + call pargstr (Memc[cmd]) + } else + call strcpy (Memc[cmd], EP_OUTPUT(ep), EP_SZFNAME) + } + case RADIUS: + call gargr (rval) + if (nscan() == 1) { + call printf ("radius %g\n") + call pargr (EP_RADIUS(ep)) + } else { + EP_RADIUS(ep) = rval + call clputr ("radius", EP_RADIUS(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":radius %g\n") + call pargr (EP_RADIUS(ep)) + } + } + case SEARCH: + call gargr (rval) + if (nscan() == 1) { + call printf ("search %g\n") + call pargr (EP_SEARCH(ep)) + } else { + EP_SEARCH(ep) = rval + call clputr ("search", EP_SEARCH(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":search %g\n") + call pargr (EP_SEARCH(ep)) + } + } + case SIGMA: + call gargr (rval) + if (nscan() == 1) { + call printf ("sigma %g\n") + call pargr (EP_SIGMA(ep)) + } else { + EP_SIGMA(ep) = rval + call clputr ("sigma", EP_SIGMA(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":sigma %g\n") + call pargr (EP_SIGMA(ep)) + } + } + case VALUE: + call gargr (rval) + if (nscan() == 1) { + call printf ("value %g\n") + call pargr (EP_VALUE(ep)) + } else { + EP_VALUE(ep) = rval + call clputr ("value", EP_VALUE(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":value %g\n") + call pargr (EP_VALUE(ep)) + } + } + case MINVALUE: + call gargr (rval) + if (nscan() == 1) { + call printf ("minvalue %g\n") + call pargr (EP_MINVALUE(ep)) + } else { + EP_MINVALUE(ep) = rval + call clputr ("minvalue", EP_MINVALUE(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":minvalue %g\n") + call pargr (EP_MINVALUE(ep)) + } + } + case MAXVALUE: + call gargr (rval) + if (nscan() == 1) { + call printf ("maxvalue %g\n") + call pargr (EP_MAXVALUE(ep)) + } else { + EP_MAXVALUE(ep) = rval + call clputr ("maxvalue", EP_MAXVALUE(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":maxvalue %g\n") + call pargr (EP_MAXVALUE(ep)) + } + } + case WIDTH: + call gargr (rval) + if (nscan() == 1 || rval < 1.) { + call printf ("width %g\n") + call pargr (EP_WIDTH(ep)) + } else { + EP_WIDTH(ep) = max (1., rval) + call clputr ("width", EP_WIDTH(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":width %g\n") + call pargr (EP_WIDTH(ep)) + } + } + case WRITE: + call gargwrd (Memc[cmd], SZ_FNAME) + ival = YES + if (nscan() == 1) + call strcpy (EP_OUTPUT(ep), Memc[cmd], SZ_FNAME) + else if (strne (Memc[cmd], EP_INPUT(ep))) { + if (imaccess (Memc[cmd], READ_ONLY) == YES) { + call eprintf ("Image %s exists\n") + call pargstr (Memc[cmd]) + ival = NO + } + } + + if (ival == YES) { + call printf ("output %s\n") + call pargstr (Memc[cmd]) + if (imaccess (Memc[cmd], READ_ONLY) == YES) + call imdelete (Memc[cmd]) + call imunmap (EP_IM(ep)) + call ep_imcopy (EP_WORK(ep), Memc[cmd]) + EP_IM(ep) = immap (EP_WORK(ep), READ_WRITE, 0) + } + case XORDER: + call gargi (ival) + if (nscan() == 1) { + call printf ("xorder %d\n") + call pargi (EP_XORDER(ep)) + } else { + EP_XORDER(ep) = max (0, ival) + call clputi ("xorder", EP_XORDER(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":xorder %d\n") + call pargi (EP_XORDER(ep)) + } + } + case YORDER: + call gargi (ival) + if (nscan() == 1) { + call printf ("yorder %d\n") + call pargi (EP_YORDER(ep)) + } else { + EP_YORDER(ep) = max (0, ival) + call clputi ("yorder", EP_YORDER(ep)) + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), ":yorder %d\n") + call pargi (EP_YORDER(ep)) + } + } + default: + call printf ("Unrecognized or ambiguous command\007") + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imedit/epconstant.x b/pkg/images/tv/imedit/epconstant.x new file mode 100644 index 00000000..0a168a19 --- /dev/null +++ b/pkg/images/tv/imedit/epconstant.x @@ -0,0 +1,51 @@ +include "epix.h" + +# EP_CONSTANT -- Replace aperture by constant value. +# The aperture is first centered. + +procedure ep_constant (ep, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates + +int i, x1, x2, y1, y2 +pointer mask + +begin + i = max (5., abs (EP_SEARCH(ep)) + 1) + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, yb) - i + y2 = max (ya, yb) + i + call ep_gdata (ep, x1, x2, y1, y2) + if (EP_OUTDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + + call ep_search (ep, Memr[EP_OUTDATA(ep)], EP_NX(ep), + EP_NY(ep), ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + call ep_constant1 (Memr[EP_OUTDATA(ep)], Memi[mask], EP_NPTS(ep), + EP_VALUE(ep)) + + call mfree (mask, TY_INT) + } +end + + +# EP_CONSTANT1 -- Replace aperture by constant value. + +procedure ep_constant1 (data, mask, npts, value) + +real data[npts] # Data subraster +int mask[npts] # Mask subraster +int npts # Number of points +real value # Substitution value + +int i + +begin + do i = 1, npts + if (mask[i] == 1) + data[i] = value +end diff --git a/pkg/images/tv/imedit/epdisplay.x b/pkg/images/tv/imedit/epdisplay.x new file mode 100644 index 00000000..1b76e5b1 --- /dev/null +++ b/pkg/images/tv/imedit/epdisplay.x @@ -0,0 +1,196 @@ +include +include "epix.h" + +# EP_DISPLAY -- Display an image using the specified command. +# This is a temporary image display interface using CLCMDW to call +# the standard display task. Image sections and the fill option +# can be used to simulate zoom. One complication is that we have to +# close the image to avoid multiple access to the image. This +# requires saving the original input subraster to allow undoing +# a change after display. + +procedure ep_display (ep, image, erase) + +pointer ep # EPIX structure +char image[ARB] # Image +bool erase # Erase + +pointer temp, immap(), imgs2r(), imps2r() + +begin + # If the output has been modified save and restore the original + # input subraster for later undoing. + + if (EP_OUTDATA(ep) != NULL) { + call malloc (temp, EP_NPTS(ep), TY_REAL) + call amovr (Memr[EP_INDATA(ep)], Memr[temp], EP_NPTS(ep)) + call imunmap (EP_IM(ep)) + call ep_command (ep, image, erase) + erase = false + EP_IM(ep) = immap (image, READ_WRITE, 0) + EP_OUTDATA(ep) = imps2r (EP_IM(ep), EP_X1(ep), + EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) + EP_INDATA(ep) = imgs2r (EP_IM(ep), EP_X1(ep), + EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) + call amovr (Memr[EP_INDATA(ep)], Memr[EP_OUTDATA(ep)], + EP_NPTS(ep)) + call amovr (Memr[temp], Memr[EP_INDATA(ep)], EP_NPTS(ep)) + call mfree (temp, TY_REAL) + } else { + call imunmap (EP_IM(ep)) + call ep_command (ep, image, erase) + erase = false + EP_IM(ep) = immap (image, READ_WRITE, 0) + } +end + + +define PARAMS "|$image|$erase|" +define IMAGE 1 +define ERASE 2 + +# EP_COMMAND -- Format a command with argument substitution. This +# technique allows use of some other display command (such as CONTOUR). + +procedure ep_command (ep, image, erase) + +pointer ep # EPIX structure +char image[ARB] # Image name +bool erase # Erase? + +int i, j, k, nscan(), strdic(), stridxs() +pointer sp, cmd, word + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (word, SZ_LINE, TY_CHAR) + + call sscan (EP_COMMAND(ep)) + + Memc[cmd] = EOS + do i = 1, 100 { + call gargwrd (Memc[word], SZ_LINE) + if (nscan() != i) + break + j = stridxs ("$", Memc[word]) - 1 + if (j >= 0) { + k = strdic (Memc[word+j], Memc[word+j], SZ_LINE, PARAMS) + switch (k) { + case IMAGE: + call sprintf (Memc[word+j], SZ_LINE-j, "%s%s") + call pargstr (image) + call pargstr (EP_SECTION(ep)) + case ERASE: + call sprintf (Memc[word+j], SZ_LINE-j, "%b") + call pargb (erase) + } + } + call strcat (Memc[word], Memc[cmd], SZ_LINE) + call strcat (" ", Memc[cmd], SZ_LINE) + } + + if (i > 1) { + call clcmdw (Memc[cmd]) + erase = false + } + + call sfree (sp) +end + + +# EP_ZOOM -- Set an image section centered on the cursor for possible zooming. +# Zoom is simulated by loading a subraster of the image. If the image display +# supports fill the frame this will give the effect of a zoom. + +procedure ep_zoom (ep, xa, ya, xb, yb, key, erase) + +pointer ep # EPIX structure +int xa, ya # Cursor +int xb, yb # Cursor +int key # Cursor key +bool erase # Erase? + +real zoom +int nc, nl, nx, ny, zx, zy, x1, x2, y1, y2 +data zoom/1./ + +begin + erase = true + + switch (key) { + case '0': + zoom = 1. + case 'E': + nc = IM_LEN(EP_IM(ep),1) + nl = IM_LEN(EP_IM(ep),2) + nx = abs (xa - xb) + 1 + ny = abs (ya - yb) + 1 + zoom = max (1., min (nc / real (nx), nl / real (ny))) + zx = (xa + xb) / 2. + zy = (ya + yb) / 2. + case 'P': + zoom = max (1., zoom / 2) + zx = xa + zy = ya + case 'Z': + zoom = 2 * zoom + zx = xa + zy = ya + } + + if (zoom == 1.) { + EP_SECTION(ep) = EOS + return + } + + nc = IM_LEN(EP_IM(ep),1) + nl = IM_LEN(EP_IM(ep),2) + nx = nc / zoom + ny = nl / zoom + + switch (key) { + case '1': + zx = zx + .4 * nx + zy = zy + .4 * ny + case '2': + zy = zy + .4 * ny + case '3': + zx = zx - .4 * nx + zy = zy + .4 * ny + case '4': + zx = zx + .4 * nx + case '5', 'r', 'R': + erase = false + case '6': + zx = zx - .4 * nx + case '7': + zx = zx + .4 * nx + zy = zy - .4 * ny + case '8': + zy = zy - .4 * ny + case '9': + zx = zx - .4 * nx + zy = zy - .4 * ny + } + + # Insure the section is in bounds. + x1 = max (1, zx - nx / 2) + x2 = min (nc, x1 + nx) + x1 = max (1, x2 - nx) + y1 = max (1, zy - ny / 2) + y2 = min (nl, y1 + ny) + y1 = max (1, y2 - ny) + + zx = (x1 + x2) / 2 + zy = (y1 + y2) / 2 + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # Format the image section. + call sprintf (EP_SECTION(ep), EP_SZFNAME, "[%d:%d,%d:%d]") + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) +end diff --git a/pkg/images/tv/imedit/epdosurface.x b/pkg/images/tv/imedit/epdosurface.x new file mode 100644 index 00000000..70866bb1 --- /dev/null +++ b/pkg/images/tv/imedit/epdosurface.x @@ -0,0 +1,35 @@ +include "epix.h" + +# EP_DOSURFACE -- Display surface plots. +# There are two modes. If there is no output subraster then just +# display the input subraster otherwise display both. The orientation +# is given by the user. + +procedure ep_dosurface (ep) + +pointer ep # EPIX structure +pointer gp, gopen() + +begin + if (EP_INDATA(ep) == NULL && EP_OUTDATA(ep) == NULL) { + call eprintf ("No region defined\n") + return + } + + gp = gopen (EP_GRAPHICS(ep), NEW_FILE, STDGRAPH) + + if (EP_OUTDATA(ep) == NULL) { + call gsview (gp, 0.03, 0.98, 0.03, 0.98) + call ep_surface (gp, Memr[EP_INDATA(ep)], EP_NX(ep), EP_NY(ep), + EP_ANGH(ep), EP_ANGV(ep)) + } else { + call gsview (gp, 0.03, 0.48, 0.03, 0.98) + call ep_surface (gp, Memr[EP_INDATA(ep)], EP_NX(ep), EP_NY(ep), + EP_ANGH(ep), EP_ANGV(ep)) + call gsview (gp, 0.53, 0.98, 0.03, 0.98) + call ep_surface (gp, Memr[EP_OUTDATA(ep)], EP_NX(ep),EP_NY(ep), + EP_ANGH(ep), EP_ANGV(ep)) + } + + call gclose (gp) +end diff --git a/pkg/images/tv/imedit/epgcur.x b/pkg/images/tv/imedit/epgcur.x new file mode 100644 index 00000000..5e424a65 --- /dev/null +++ b/pkg/images/tv/imedit/epgcur.x @@ -0,0 +1,127 @@ +include "epix.h" + +# EP_GCUR -- Get EPIX cursor value. +# This is an interface between the standard cursor input and EPIX. It +# returns an aperture consisting of an aperture type and the two integer +# pixel corners containing the aperture. This interface also provides +# for interpreting the FIXPIX type files. A default key may be +# supplied which allows simple X-Y files to be read. + +int procedure ep_gcur (ep, ap, x1, y1, x2, y2, key, strval, maxch) + +pointer ep # EPIX structure +int ap # Aperture type +int x1, y1, x2, y2 # Corners of aperture +int key # Keystroke value of cursor event +char strval[ARB] # String value, if any +int maxch + +real a, b, c, d, e +pointer sp, buf, ip +int nitems, wcs +int ctor(), clglstr(), clgcur() + +begin + # FIXPIX format consists of a rectangle with column and line ranges. + # The key returned is for interpolation across the narrow dimension + # of the rectangle. + + if (EP_FIXPIX(ep) == YES) { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Read the list structured string. + if (clglstr ("cursor", Memc[buf], SZ_LINE) == EOF) { + call sfree (sp) + return (EOF) + } + + ip = buf + nitems = 0 + if (ctor (Memc, ip, a) > 0) + nitems = nitems + 1 + if (ctor (Memc, ip, b) > 0) + nitems = nitems + 1 + if (ctor (Memc, ip, c) > 0) + nitems = nitems + 1 + if (ctor (Memc, ip, d) > 0) + nitems = nitems + 1 + + e = max (a, b) + a = min (a, b) + b = e + e = max (c, d) + c = min (c, d) + d = e + x1 = nint(a) + y1 = nint(c) + x2 = nint(b) + y2 = nint(d) + ap = APRECTANGLE + if (x2 - x1 <= y2 - y1) + key = 'c' + else + key = 'l' + + call sfree (sp) + return (nitems) + } + + # The standard cursor value is read for centered apertures and + # for two values are read for rectangular apertures. The + # returned coordinates are properly defined. + + key = EP_DEFAULT(ep) + strval[1] = EOS + nitems = clgcur ("cursor", a, b, wcs, key, strval, maxch) + switch (key) { + case 'a', 'c', 'd', 'l', 'f', 'j', 'v': + call printf ("again:") + nitems = clgcur ("cursor", c, d, wcs, key, strval, SZ_LINE) + call printf ("\n") + if (!IS_INDEF(a)) + x1 = nint (a) + if (!IS_INDEF(b)) + y1 = nint (b) + if (!IS_INDEF(c)) + x2 = nint (c) + if (!IS_INDEF(d)) + y2 = nint (d) + if (key == 'f' || key == 'v') { + if (abs (x2-x1) > abs (y2-y1)) + ap = APLDIAG + else + ap = APCDIAG + } else + ap = APRECTANGLE + case 'b', 'e', 'k', 'm', 'n', 'p', 's', ' ': + if (!IS_INDEF(a)) { + x1 = nint (a - EP_RADIUS(ep)) + x2 = nint (a + EP_RADIUS(ep)) + } + if (!IS_INDEF(b)) { + y1 = nint (b - EP_RADIUS(ep)) + y2 = nint (b + EP_RADIUS(ep)) + } + ap = EP_APERTURE(ep) + case 'E': + call printf ("again:") + nitems = clgcur ("cursor", c, d, wcs, key, strval, SZ_LINE) + call printf ("\n") + if (!IS_INDEF(a)) + x1 = nint (a) + if (!IS_INDEF(b)) + y1 = nint (b) + if (!IS_INDEF(c)) + x2 = nint (c) + if (!IS_INDEF(d)) + y2 = nint (d) + default: + if (!IS_INDEF(a)) + x1 = nint (a) + if (!IS_INDEF(b)) + y1 = nint (b) + } + + return (nitems) +end diff --git a/pkg/images/tv/imedit/epgdata.x b/pkg/images/tv/imedit/epgdata.x new file mode 100644 index 00000000..163d7478 --- /dev/null +++ b/pkg/images/tv/imedit/epgdata.x @@ -0,0 +1,70 @@ +include +include "epix.h" + +# EP_GDATA -- Get input and output image subrasters with boundary checking. +# Null pointer are returned if entirely out of bounds. + +procedure ep_gdata (ep, x1, x2, y1, y2) + +pointer ep # EPIX pointer +int x1, x2, y1, y2 # Subraster limits + +int nc, nl +pointer im, imgs2r(), imps2r() + +begin + im = EP_IM(ep) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + if (x2 < 1 || x1 >= nc || y2 < 1 || y1 >= nl) { + call eprintf ("Pixel out of bounds\n") + EP_INDATA(ep) = NULL + EP_OUTDATA(ep) = NULL + return + } + + EP_X1(ep) = max (1, x1) + EP_X2(ep) = min (nc, x2) + EP_Y1(ep) = max (1, y1) + EP_Y2(ep) = min (nl, y2) + EP_NX(ep) = EP_X2(ep) - EP_X1(ep) + 1 + EP_NY(ep) = EP_Y2(ep) - EP_Y1(ep) + 1 + EP_NPTS(ep) = EP_NX(ep) * EP_NY(ep) + EP_OUTDATA(ep) = imps2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) + EP_INDATA(ep) = imgs2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) + call amovr (Memr[EP_INDATA(ep)], Memr[EP_OUTDATA(ep)], EP_NPTS(ep)) +end + + +# EP_GINDATA -- Get input image data only with boundary checking. +# A null pointer is returned if entirely out of bounds. + +procedure ep_gindata (ep, x1, x2, y1, y2) + +pointer ep # EPIX pointer +int x1, x2, y1, y2 # Subraster limits + +int nc, nl +pointer im, imgs2r() + +begin + im = EP_IM(ep) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + if (x2 < 1 || x1 >= nc || y2 < 1 || y1 >= nl) { + call eprintf ("Pixel out of bounds\n") + EP_INDATA(ep) = NULL + return + } + + EP_X1(ep) = max (1, x1) + EP_X2(ep) = min (nc, x2) + EP_Y1(ep) = max (1, y1) + EP_Y2(ep) = min (nl, y2) + EP_NX(ep) = EP_X2(ep) - EP_X1(ep) + 1 + EP_NY(ep) = EP_Y2(ep) - EP_Y1(ep) + 1 + EP_NPTS(ep) = EP_NX(ep) * EP_NY(ep) + EP_INDATA(ep) = imgs2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) +end diff --git a/pkg/images/tv/imedit/epgsfit.x b/pkg/images/tv/imedit/epgsfit.x new file mode 100644 index 00000000..976af322 --- /dev/null +++ b/pkg/images/tv/imedit/epgsfit.x @@ -0,0 +1,74 @@ +include +include "epix.h" + +# EP_GSFIT -- Fit the background annulus. + +procedure ep_gsfit (ep, data, mask, x, y, w, nx, ny, gs) + +pointer ep # EPIX structure +real data[nx,ny] # Data subraster +int mask[nx,ny] # Mask subraster +real x[nx,ny] # X positions +real y[nx,ny] # Y positions +real w[nx,ny] # Weights +int nx, ny # Subraster size +pointer gs # Surface pointer (returned) + +int i, j, n, npts, xo, yo +pointer sp, work +real amedr() + +begin + call smark (sp) + call salloc (work, nx * ny, TY_REAL) + + gs = NULL + npts = nx * ny + + if (EP_XORDER(ep) == 0 || EP_YORDER(ep) == 0) { + n = 0 + do j = 1, ny { + do i = 1, nx { + if (mask[i,j] == 2) { + Memr[work+n] = data[i,j] + n = n + 1 + } + } + } + call amovkr (amedr (Memr[work], n), Memr[work], npts) + xo = 1 + yo = 1 + } else { + call amovr (data, Memr[work], npts) + xo = EP_XORDER(ep) + yo = EP_YORDER(ep) + } + + n = 0 + do j = 1, ny { + do i = 1, nx { + x[i,j] = i + y[i,j] = j + if (mask[i,j] == 2) { + w[i,j] = 1. + n = n + 1 + } else + w[i,j] = 0. + } + } + + if (n > 7) { + repeat { + call gsinit (gs, GS_POLYNOMIAL, xo, yo, YES, + 1., real (nx), 1., real (ny)) + call gsfit (gs, x, y, Memr[work], w, npts, WTS_USER, n) + if (n == OK) + break + xo = max (1, xo - 1) + yo = max (1, yo - 1) + } + } else + call eprintf ("ERROR: Insufficient background points\n") + + call sfree (sp) +end diff --git a/pkg/images/tv/imedit/epimcopy.x b/pkg/images/tv/imedit/epimcopy.x new file mode 100644 index 00000000..cb0094eb --- /dev/null +++ b/pkg/images/tv/imedit/epimcopy.x @@ -0,0 +1,72 @@ +include + +# EP_IMCOPY -- Copy an image. Use sequential routines to permit copying +# images of any dimension. Perform pixel i/o in the datatype of the image, +# to avoid unnecessary type conversion. + +procedure ep_imcopy (image1, image2) + +char image1[ARB] # Input image +char image2[ARB] # Output image + +int npix, junk +pointer buf1, buf2, im1, im2 +long v1[IM_MAXDIM], v2[IM_MAXDIM] + +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() +errchk immap +errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx +errchk impnls, impnli, impnll, impnlr, impnld, impnlx + +begin + # Map images. + im1 = immap (image1, READ_ONLY, 0) + im2 = immap (image2, NEW_COPY, im1) + + # Setup start vector for sequential reads and writes. + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + + # Copy the image. + npix = IM_LEN(im1, 1) + switch (IM_PIXTYPE(im1)) { + case TY_SHORT: + while (imgnls (im1, buf1, v1) != EOF) { + junk = impnls (im2, buf2, v2) + call amovs (Mems[buf1], Mems[buf2], npix) + } + case TY_USHORT, TY_INT: + while (imgnli (im1, buf1, v1) != EOF) { + junk = impnli (im2, buf2, v2) + call amovi (Memi[buf1], Memi[buf2], npix) + } + case TY_LONG: + while (imgnll (im1, buf1, v1) != EOF) { + junk = impnll (im2, buf2, v2) + call amovl (Meml[buf1], Meml[buf2], npix) + } + case TY_REAL: + while (imgnlr (im1, buf1, v1) != EOF) { + junk = impnlr (im2, buf2, v2) + call amovr (Memr[buf1], Memr[buf2], npix) + } + case TY_DOUBLE: + while (imgnld (im1, buf1, v1) != EOF) { + junk = impnld (im2, buf2, v2) + call amovd (Memd[buf1], Memd[buf2], npix) + } + case TY_COMPLEX: + while (imgnlx (im1, buf1, v1) != EOF) { + junk = impnlx (im2, buf2, v2) + call amovx (Memx[buf1], Memx[buf2], npix) + } + default: + call error (1, "unknown pixel datatype") + } + + # Unmap the images. + call imunmap (im2) + call imunmap (im1) +end diff --git a/pkg/images/tv/imedit/epinput.x b/pkg/images/tv/imedit/epinput.x new file mode 100644 index 00000000..8b8e9c4d --- /dev/null +++ b/pkg/images/tv/imedit/epinput.x @@ -0,0 +1,55 @@ +include "epix.h" + +# EP_INPUT -- Replace aperture by data from original input image. +# The aperture is first centered. + +procedure ep_input (ep, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates + +int i, x1, x2, y1, y2 +pointer mask, indata, im, immap(), imgs2r() + +begin + i = max (5., abs (EP_SEARCH(ep)) + 1) + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, yb) - i + y2 = max (ya, yb) + i + call ep_gdata (ep, x1, x2, y1, y2) + if (EP_OUTDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + + call ep_search (ep, Memr[EP_OUTDATA(ep)], EP_NX(ep), + EP_NY(ep), ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + + im = immap (EP_INPUT(ep), READ_ONLY, 0) + indata = imgs2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), EP_Y2(ep)) + call ep_input1 (Memr[indata], Memi[mask], Memr[EP_OUTDATA(ep)], + EP_NPTS(ep)) + call imunmap (im) + + call mfree (mask, TY_INT) + } +end + + +# EP_INPUT1 -- Replace aperture by input data. + +procedure ep_input1 (indata, mask, outdata, npts) + +real indata[npts] # Data subraster +int mask[npts] # Mask subraster +real outdata[npts] # Input buffer data +int npts # Number of points + +int i + +begin + do i = 1, npts + if (mask[i] == 1) + outdata[i] = indata[i] +end diff --git a/pkg/images/tv/imedit/epix.h b/pkg/images/tv/imedit/epix.h new file mode 100644 index 00000000..d794ac8b --- /dev/null +++ b/pkg/images/tv/imedit/epix.h @@ -0,0 +1,50 @@ +# Parameter data structure + +define EP_SZFNAME 99 # Length of file name +define EP_SZLINE 199 # Length of line +define EP_LEN 379 # Length of EP structure + +define EP_INPUT Memc[P2C($1)] # Input image name +define EP_OUTPUT Memc[P2C($1+50)] # Output image name +define EP_WORK Memc[P2C($1+100)] # Working image name +define EP_SECTION Memc[P2C($1+150)] # Image section +define EP_GRAPHICS Memc[P2C($1+200)] # Graphics device +define EP_COMMAND Memc[P2C($1+250)] # Display command + +define EP_ANGH Memr[P2R($1+350)] # Horizontal viewing angle +define EP_ANGV Memr[P2R($1+351)] # Vertical viewing angle +define EP_APERTURE Memi[$1+352] # Aperture type +define EP_AUTODISPLAY Memi[$1+353] # Automatic image display? +define EP_AUTOSURFACE Memi[$1+354] # Automatic surface plots? +define EP_BUFFER Memr[P2R($1+355)] # Background buffer width +define EP_DEFAULT Memi[$1+356] # Default edit option +define EP_DISPLAY Memi[$1+357] # Display images? +define EP_FIXPIX Memi[$1+358] # Fixpix input? +define EP_RADIUS Memr[P2R($1+359)] # Aperture radius +define EP_SEARCH Memr[P2R($1+360)] # Search radius +define EP_SIGMA Memr[P2R($1+361)] # Added noise sigma +define EP_VALUE Memr[P2R($1+362)] # Substitution value +define EP_MINVALUE Memr[P2R($1+363)] # Minimum value for edit +define EP_MAXVALUE Memr[P2R($1+364)] # Maximum value for edit +define EP_WIDTH Memr[P2R($1+365)] # Background width +define EP_XORDER Memi[$1+366] # Background xorder +define EP_YORDER Memi[$1+367] # Background xorder + +define EP_LOGFD Memi[$1+368] # Log file descriptor +define EP_IM Memi[$1+369] # IMIO pointer +define EP_INDATA Memi[$1+370] # Input data pointer +define EP_OUTDATA Memi[$1+371] # Output data pointer +define EP_NX Memi[$1+372] # Number of columns in subraster +define EP_NY Memi[$1+373] # Number of lines in subraster +define EP_NPTS Memi[$1+374] # Number of pixels in subraster +define EP_X1 Memi[$1+375] # Starting column of subraster +define EP_Y1 Memi[$1+376] # Starting line of subraster +define EP_X2 Memi[$1+377] # Ending column of subraster +define EP_Y2 Memi[$1+378] # Ending line of subraster + +define APTYPES "|circular|square|" # Aperture types +define APRECTANGLE 0 # Rectangular aperture +define APCIRCULAR 1 # Circular aperture +define APSQUARE 2 # Square aperture +define APCDIAG 3 # Diagonal with column interp +define APLDIAG 4 # Diagonal with column interp diff --git a/pkg/images/tv/imedit/epline.x b/pkg/images/tv/imedit/epline.x new file mode 100644 index 00000000..2644beb8 --- /dev/null +++ b/pkg/images/tv/imedit/epline.x @@ -0,0 +1,80 @@ +include "epix.h" + +# EP_LINE -- Replace aperture by line interpolation from background annulus. +# The aperture is first centered. The interpolation is across lines +# from the nearest pixel in the background annulus. Gaussian noise may +# be added. + +procedure ep_line (ep, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates + +int i, x1, x2, y1, y2 +pointer mask, gs + +begin + i = abs (EP_SEARCH(ep)) + EP_BUFFER(ep) + 1 + x1 = min (xa, xb) + x2 = max (xa, xb) + y1 = min (ya, yb) - i + y2 = max (ya, yb) + i + call ep_gdata (ep, x1, x2, y1, y2) + if (EP_OUTDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + + call ep_search (ep, Memr[EP_OUTDATA(ep)], EP_NX(ep), + EP_NY(ep), ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + call ep_line1 (Memr[EP_OUTDATA(ep)], Memi[mask], + EP_NX(ep), EP_NY(ep)) + if (!IS_INDEF (EP_SIGMA(ep))) + call ep_noise (EP_SIGMA(ep), Memr[EP_OUTDATA(ep)], + Memi[mask], Memr[EP_OUTDATA(ep)], Memr[EP_OUTDATA(ep)], + EP_NPTS(ep), gs) + + call mfree (mask, TY_INT) + } +end + + +# EP_LINE1 -- Interpolate across lines. + +procedure ep_line1 (data, mask, nx, ny) + +real data[nx,ny] # Data subraster +int mask[nx,ny] # Mask subraster +int nx, ny # Number of points + +int i, j, ya, yb, yc, yd +real a, b + +begin + do i = 1, nx { + for (ya=1; ya<=ny && mask[i,ya]!=1; ya=ya+1) + ; + if (ya > ny) + next + for (yb=ny; yb>ya && mask[i,yb]!=1; yb=yb-1) + ; + for (yc=ya; yc>=1 && mask[i,yc]!=2; yc=yc-1) + ; + for (yd=yb; yd<=ny && mask[i,yd]!=2; yd=yd+1) + ; + if (yc < 1 && yd > ny) + next + else if (yc < 1) + do j = ya, yb + data[i,j] = data[i,yd] + else if (yd > ny) + do j = ya, yb + data[i,j] = data[i,yc] + else { + a = data[i,yc] + b = (data[i,yd] - a) / (yd - yc) + do j = ya, yb + data[i,j] = a + b * (j - yc) + } + } +end diff --git a/pkg/images/tv/imedit/epmask.x b/pkg/images/tv/imedit/epmask.x new file mode 100644 index 00000000..12fd8fc9 --- /dev/null +++ b/pkg/images/tv/imedit/epmask.x @@ -0,0 +1,177 @@ +include +include "epix.h" + +# EP_MASK -- Make a mask array with 1=aperture and 2=background annulus. +# +# Exclude values outside a specified range. + +procedure ep_mask (ep, mask, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +pointer mask # Mask pointer +int ap # Aperture type +int xa, ya, xb, yb # Aperture + +int xc, yc, i, j +real rad, r, a, b, c, d, minv, maxv +int x1a, x1b, x1c, x2a, x2b, x2c, y1a, y1b, y1c, y2a, y2b, y2c +pointer sp, line, ptr1, ptr2 + +begin + rad = max (0.5, EP_RADIUS(ep)) + + switch (ap) { + case APCIRCULAR: + xc = nint ((xa + xb) / 2.) + yc = nint ((ya + yb) / 2.) + + a = rad ** 2 + b = (rad + EP_BUFFER(ep)) ** 2 + c = (rad + EP_BUFFER(ep) + EP_WIDTH(ep)) ** 2 + + ptr1 = mask + do j = EP_Y1(ep), EP_Y2(ep) { + d = (j - yc) ** 2 + do i = EP_X1(ep), EP_X2(ep) { + r = d + (i - xc) ** 2 + if (r <= a) + Memi[ptr1] = 1 + else if (r >= b && r <= c) + Memi[ptr1] = 2 + else + Memi[ptr1] = 0 + ptr1 = ptr1 + 1 + } + } + case APCDIAG: + a = rad + b = rad + EP_BUFFER(ep) + c = rad + EP_BUFFER(ep) + EP_WIDTH(ep) + + if (yb - ya != 0) + d = real (xb - xa) / (yb - ya) + else + d = 1. + + ptr1 = mask + do j = EP_Y1(ep), EP_Y2(ep) { + xc = xa + d * (j - ya) + do i = EP_X1(ep), EP_X2(ep) { + r = abs (i - xc) + if (r <= a) + Memi[ptr1] = 1 + else if (r >= b && r <= c) + Memi[ptr1] = 2 + else + Memi[ptr1] = 0 + ptr1 = ptr1 + 1 + } + } + case APLDIAG: + a = rad + b = rad + EP_BUFFER(ep) + c = rad + EP_BUFFER(ep) + EP_WIDTH(ep) + + if (xb - xa != 0) + d = real (yb - ya) / (xb - xa) + else + d = 1. + + ptr1 = mask + do j = EP_Y1(ep), EP_Y2(ep) { + do i = EP_X1(ep), EP_X2(ep) { + yc = ya + d * (i - xa) + r = abs (j - yc) + if (r <= a) + Memi[ptr1] = 1 + else if (r >= b && r <= c) + Memi[ptr1] = 2 + else + Memi[ptr1] = 0 + ptr1 = ptr1 + 1 + } + } + default: + call smark (sp) + call salloc (line, EP_NX(ep), TY_INT) + + x1a = max (EP_X1(ep), min (xa, xb)) + x1b = max (EP_X1(ep), int (x1a - EP_BUFFER(ep))) + x1c = max (EP_X1(ep), int (x1a - EP_BUFFER(ep) - EP_WIDTH(ep))) + x2a = min (EP_X2(ep), max (xa, xb)) + x2b = min (EP_X2(ep), int (x2a + EP_BUFFER(ep))) + x2c = min (EP_X2(ep), int (x2a + EP_BUFFER(ep) + EP_WIDTH(ep))) + + y1a = max (EP_Y1(ep), min (ya, yb)) + y1b = max (EP_Y1(ep), int (y1a - EP_BUFFER(ep))) + y1c = max (EP_Y1(ep), int (y1a - EP_BUFFER(ep) - EP_WIDTH(ep))) + y2a = min (EP_Y2(ep), max (ya, yb)) + y2b = min (EP_Y2(ep), int (y2a + EP_BUFFER(ep))) + y2c = min (EP_Y2(ep), int (y2a + EP_BUFFER(ep) + EP_WIDTH(ep))) + + ptr1 = line - EP_X1(ep) + ptr2 = mask - EP_Y1(ep) * EP_NX(ep) + + for (i=EP_X1(ep); i maxv) + Memi[ptr1] = 0 + } + ptr1 = ptr1 + 1 + ptr2 = ptr2 + 1 + } + } +end diff --git a/pkg/images/tv/imedit/epmove.x b/pkg/images/tv/imedit/epmove.x new file mode 100644 index 00000000..687a200e --- /dev/null +++ b/pkg/images/tv/imedit/epmove.x @@ -0,0 +1,129 @@ +include "epix.h" + +# EP_MOVE -- Replace the output aperture by the data in the input aperture. +# There is no centering. A background is fit to the input data and subtracted +# and then a background is fit to the output aperture and added to the +# input aperture data. + +procedure ep_move (ep, ap, xa1, ya1, xb1, yb1, xa2, ya2, xb2, yb2, key) + +pointer ep # EPIX structure +int ap # Aperture type +int xa1, ya1, xb1, yb1 # Aperture coordinates +int xa2, ya2, xb2, yb2 # Aperture coordinates +int key # Key + +int i, x1, x2, y1, y2 +pointer bufdata, mask, x, y, w + +begin + i = EP_BUFFER(ep) + EP_WIDTH(ep) + 1 + x1 = min (xa1, xb1) - i + x2 = max (xa1, xb1) + i + y1 = min (ya1, yb1) - i + y2 = max (ya1, yb1) + i + call ep_gindata (ep, x1, x2, y1, y2) + if (EP_INDATA(ep) != NULL) { + call malloc (bufdata, EP_NPTS(ep), TY_REAL) + call malloc (mask, EP_NPTS(ep), TY_INT) + call malloc (x, EP_NPTS(ep), TY_REAL) + call malloc (y, EP_NPTS(ep), TY_REAL) + call malloc (w, EP_NPTS(ep), TY_REAL) + + call amovr (Memr[EP_INDATA(ep)], Memr[bufdata], EP_NPTS(ep)) + call ep_mask (ep, mask, ap, xa1, ya1, xb1, yb1) + i = EP_BUFFER(ep) + EP_WIDTH(ep) + 1 + x1 = min (xa2, xb2) - i + x2 = max (xa2, xb2) + i + y1 = min (ya2, yb2) - i + y2 = max (ya2, yb2) + i + i = EP_NPTS(ep) + call ep_gdata (ep, x1, x2, y1, y2) + if (i != EP_NPTS(ep)) { + call eprintf ("Raster sizes don't match\n") + EP_OUTDATA(ep) = NULL + } + if (EP_OUTDATA(ep) != NULL) { + switch (key) { + case 'm': + call ep_movem (ep, Memr[bufdata], Memr[EP_OUTDATA(ep)], + Memi[mask], Memr[x], Memr[y], Memr[w], + EP_NX(ep), EP_NY(ep)) + case 'n': + call ep_moven (ep, Memr[bufdata], Memr[EP_OUTDATA(ep)], + Memi[mask], Memr[x], Memr[y], Memr[w], + EP_NX(ep), EP_NY(ep)) + } + } + + call mfree (bufdata, TY_REAL) + call mfree (mask, TY_INT) + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (w, TY_REAL) + } +end + + +# EP_MOVEM -- Move the input aperture to the output. + +procedure ep_movem (ep, indata, outdata, mask, x, y, w, nx, ny) + +pointer ep # EPIX structure +real indata[nx,ny] # Input data subraster +real outdata[nx,ny] # Output data subraster +int mask[nx,ny] # Mask subraster +real x[nx,ny], y[nx,ny] # Coordinates +real w[nx,ny] # Weights +int nx, ny # Size of subraster + +int i, j +real gseval() +pointer gsin, gsout + +begin + call ep_gsfit (ep, indata, mask, x, y, w, nx, ny, gsin) + if (gsin == NULL) + return + call ep_gsfit (ep, outdata, mask, x, y, w, nx, ny, gsout) + if (gsout == NULL) { + call gsfree (gsin) + return + } + do j = 1, ny + do i = 1, nx + if (mask[i,j] == 1) + outdata[i,j] = indata[i,j] - gseval (gsin, x[i,j], y[i,j]) + + gseval (gsout, x[i,j], y[i,j]) + call gsfree (gsin) + call gsfree (gsout) +end + + +# EP_MOVEN -- Add the input aperture to the output. + +procedure ep_moven (ep, indata, outdata, mask, x, y, w, nx, ny) + +pointer ep # EPIX structure +real indata[nx,ny] # Input data subraster +real outdata[nx,ny] # Output data subraster +int mask[nx,ny] # Mask subraster +real x[nx,ny], y[nx,ny] # Coordinates +real w[nx,ny] # Weights +int nx, ny # Size of subraster + +int i, j +real gseval() +pointer gs + +begin + call ep_gsfit (ep, indata, mask, x, y, w, nx, ny, gs) + if (gs == NULL) + return + do j = 1, ny + do i = 1, nx + if (mask[i,j] == 1) + outdata[i,j] = indata[i,j] - gseval (gs, x[i,j], y[i,j]) + + outdata[i,j] + call gsfree (gs) +end diff --git a/pkg/images/tv/imedit/epnoise.x b/pkg/images/tv/imedit/epnoise.x new file mode 100644 index 00000000..796e5038 --- /dev/null +++ b/pkg/images/tv/imedit/epnoise.x @@ -0,0 +1,95 @@ +# EP_NOISE -- Add noise. +# If the sigma is zero add no noise. If a nonzero sigma is given then +# add gaussian random noise. If the sigma is INDEF then use histogram +# sampling from the background. The background histogram is corrected +# for a background function. The histogram is sampled by sorting the +# background values and selecting uniformly from the central 80%. + +procedure ep_noise (sigma, data, mask, x, y, npts, gs) + +real sigma # Noise sigma +real data[npts] # Image data +int mask[npts] # Mask (1=object, 2=background) +real x[npts], y[npts] # Coordinates +int npts # Number of pixels in subraster +pointer gs # Background surface + +int i, j, nbg +real a, b, urand(), gseval(), ep_gauss() +pointer bg + +long seed +data seed /1/ + +begin + # Add gaussian random noise. + if (!IS_INDEF (sigma)) { + if (sigma <= 0.) + return + do i = 1, npts { + if (mask[i] == 1) + data[i] = data[i] + sigma * ep_gauss (seed) + } + return + } + + # Add background sampling with background slope correction. + + if (gs == NULL) + return + + call malloc (bg, npts, TY_REAL) + + nbg = 0 + do i = 1, npts { + if (mask[i] == 2) { + Memr[bg+nbg] = data[i] - gseval (gs, x[i], y[i]) + nbg = nbg + 1 + } + } + if (nbg < 10) { + call mfree (bg, TY_REAL) + return + } + + call asrtr (Memr[bg], Memr[bg], nbg) + a = .1 * nbg - 1 + b = .8 * nbg + + do i = 1, npts + if (mask[i] == 1) { + j = a + b * urand (seed) + data[i] = data[i] + Memr[bg + j] + } + + call mfree (bg, TY_REAL) +end + + +# EP_GAUSS -- Gaussian random number generator based on uniform random number +# generator. + +real procedure ep_gauss (seed) + +long seed # Random number seed + +real a, b, c, d, urand() +int flag +data flag/NO/ + +begin + if (flag == NO) { + repeat { + a = 2. * urand (seed) - 1. + b = 2. * urand (seed) - 1. + c = a * a + b * b + } until (c <= 1.) + + d = sqrt (-2. * log (c) / c) + flag = YES + return (a * d) + } else { + flag = NO + return (b * d) + } +end diff --git a/pkg/images/tv/imedit/epreplace.gx b/pkg/images/tv/imedit/epreplace.gx new file mode 100644 index 00000000..df09e50b --- /dev/null +++ b/pkg/images/tv/imedit/epreplace.gx @@ -0,0 +1,167 @@ +include +include +include "epix.h" + + +# EP_REPLACE -- Replace all pixels that are ==, <=, or >= to the value at the +# reference pixel. Since this allocates and gets sections this may result in +# the entire image being put into memory with potential memory problems. It +# is intended for use with masks that have regions of constant values. +# +# Note that this version assumes the pixel values may be ACE object masks. + +$for (ir) +procedure ep_replace$t (ep, x, y, key) + +pointer ep #I EPIX pointer +int x, y #I Reference pixel +int key #I Key + +int i, j, nc, nl, x1, x2, y1, y2 +real minv, maxv +PIXEL val, ival, oval +pointer im, buf + +$if (datatype == i) +int andi() +$endif +pointer imgs2$t(), imps2$t() +errchk imgs2$t, imps2$t + +begin + im = EP_IM(ep) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + EP_INDATA(ep) = NULL + EP_OUTDATA(ep) = NULL + if (x < 1 || x > nc || y < 1 || y > nl) { + call eprintf ("Pixel out of bounds\n") + return + } + + # Get reference pixel value and replacement value. + buf = imgs2$t (im, x, x, y, y) + $if (datatype == i) + ival = andi (Mem$t[buf], 0777777B) + $else + ival = Mem$t[buf] + $endif + oval = EP_VALUE(ep) + minv = EP_MINVALUE(ep) + maxv = EP_MAXVALUE(ep) + if (IS_INDEFR(minv)) + minv = -MAX_REAL + if (IS_INDEFR(maxv)) + minv = MAX_REAL + + # This requires two passes to fit into the subraster model. + # First pass finds the limits of the change and the second + # makes the change. + + x1 = x+1; x2 = x-1; y1 = y+1; y2 = y-1 + do j = 1, nl { + buf = imgs2$t (im, 1, nc, j, j) + switch (key) { + case '=': + do i = 1, nc { + $if (datatype == i) + val = andi (Mem$t[buf+i-1], 0777777B) + $else + val = Mem$t[buf+i-1] + $endif + if (val != ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '<': + do i = 1, nc { + $if (datatype == i) + val = andi (Mem$t[buf+i-1], 0777777B) + $else + val = Mem$t[buf+i-1] + $endif + if (val > ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '>': + do i = 1, nc { + $if (datatype == i) + val = andi (Mem$t[buf+i-1], 0777777B) + $else + val = Mem$t[buf+i-1] + $endif + if (val < ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + } + } + + # No pixels to change. + if (x2 < x1 || y2 < y1) + return + + # Set the rasters and change the pixels. + EP_X1(ep) = x1 + EP_X2(ep) = x2 + EP_Y1(ep) = y1 + EP_Y2(ep) = y2 + EP_NX(ep) = EP_X2(ep) - EP_X1(ep) + 1 + EP_NY(ep) = EP_Y2(ep) - EP_Y1(ep) + 1 + EP_NPTS(ep) = EP_NX(ep) * EP_NY(ep) + + EP_OUTDATA(ep) = imps2$t (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + EP_INDATA(ep) = imgs2$t (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + + buf = EP_OUTDATA(ep) + call amov$t (Mem$t[EP_INDATA(ep)], Mem$t[buf], EP_NPTS(ep)) + switch (key) { + case '=': + do i = 1, EP_NPTS(ep) { + $if (datatype == i) + val = andi (Mem$t[buf], 0777777B) + $else + val = Mem$t[buf] + $endif + if (val == ival && val >= minv && val <= maxv) + Mem$t[buf] = oval + buf = buf + 1 + } + case '<': + do i = 1, EP_NPTS(ep) { + $if (datatype == i) + val = andi (Mem$t[buf], 0777777B) + $else + val = Mem$t[buf] + $endif + if (val <= ival && val >= minv && val <= maxv) + Mem$t[buf] = oval + buf = buf + 1 + } + case '>': + do i = 1, EP_NPTS(ep) { + $if (datatype == i) + val = andi (Mem$t[buf], 0777777B) + $else + val = Mem$t[buf] + $endif + if (val >= ival && val >= minv && val <= maxv) + Mem$t[buf] = oval + buf = buf + 1 + } + } +end +$endfor diff --git a/pkg/images/tv/imedit/epreplace.x b/pkg/images/tv/imedit/epreplace.x new file mode 100644 index 00000000..c79b943f --- /dev/null +++ b/pkg/images/tv/imedit/epreplace.x @@ -0,0 +1,260 @@ +include +include +include "epix.h" + + +# EP_REPLACE -- Replace all pixels that are ==, <=, or >= to the value at the +# reference pixel. Since this allocates and gets sections this may result in +# the entire image being put into memory with potential memory problems. It +# is intended for use with masks that have regions of constant values. +# +# Note that this version assumes the pixel values may be ACE object masks. + + +procedure ep_replacei (ep, x, y, key) + +pointer ep #I EPIX pointer +int x, y #I Reference pixel +int key #I Key + +int i, j, nc, nl, x1, x2, y1, y2 +real minv, maxv +int val, ival, oval +pointer im, buf + +int andi() +pointer imgs2i(), imps2i() +errchk imgs2i, imps2i + +begin + im = EP_IM(ep) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + EP_INDATA(ep) = NULL + EP_OUTDATA(ep) = NULL + if (x < 1 || x > nc || y < 1 || y > nl) { + call eprintf ("Pixel out of bounds\n") + return + } + + # Get reference pixel value and replacement value. + buf = imgs2i (im, x, x, y, y) + ival = andi (Memi[buf], 0777777B) + oval = EP_VALUE(ep) + minv = EP_MINVALUE(ep) + maxv = EP_MAXVALUE(ep) + if (IS_INDEFR(minv)) + minv = -MAX_REAL + if (IS_INDEFR(maxv)) + minv = MAX_REAL + + # This requires two passes to fit into the subraster model. + # First pass finds the limits of the change and the second + # makes the change. + + x1 = x+1; x2 = x-1; y1 = y+1; y2 = y-1 + do j = 1, nl { + buf = imgs2i (im, 1, nc, j, j) + switch (key) { + case '=': + do i = 1, nc { + val = andi (Memi[buf+i-1], 0777777B) + if (val != ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '<': + do i = 1, nc { + val = andi (Memi[buf+i-1], 0777777B) + if (val > ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '>': + do i = 1, nc { + val = andi (Memi[buf+i-1], 0777777B) + if (val < ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + } + } + + # No pixels to change. + if (x2 < x1 || y2 < y1) + return + + # Set the rasters and change the pixels. + EP_X1(ep) = x1 + EP_X2(ep) = x2 + EP_Y1(ep) = y1 + EP_Y2(ep) = y2 + EP_NX(ep) = EP_X2(ep) - EP_X1(ep) + 1 + EP_NY(ep) = EP_Y2(ep) - EP_Y1(ep) + 1 + EP_NPTS(ep) = EP_NX(ep) * EP_NY(ep) + + EP_OUTDATA(ep) = imps2i (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + EP_INDATA(ep) = imgs2i (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + + buf = EP_OUTDATA(ep) + call amovi (Memi[EP_INDATA(ep)], Memi[buf], EP_NPTS(ep)) + switch (key) { + case '=': + do i = 1, EP_NPTS(ep) { + val = andi (Memi[buf], 0777777B) + if (val == ival && val >= minv && val <= maxv) + Memi[buf] = oval + buf = buf + 1 + } + case '<': + do i = 1, EP_NPTS(ep) { + val = andi (Memi[buf], 0777777B) + if (val <= ival && val >= minv && val <= maxv) + Memi[buf] = oval + buf = buf + 1 + } + case '>': + do i = 1, EP_NPTS(ep) { + val = andi (Memi[buf], 0777777B) + if (val >= ival && val >= minv && val <= maxv) + Memi[buf] = oval + buf = buf + 1 + } + } +end + +procedure ep_replacer (ep, x, y, key) + +pointer ep #I EPIX pointer +int x, y #I Reference pixel +int key #I Key + +int i, j, nc, nl, x1, x2, y1, y2 +real minv, maxv +real val, ival, oval +pointer im, buf + +pointer imgs2r(), imps2r() +errchk imgs2r, imps2r + +begin + im = EP_IM(ep) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + + EP_INDATA(ep) = NULL + EP_OUTDATA(ep) = NULL + if (x < 1 || x > nc || y < 1 || y > nl) { + call eprintf ("Pixel out of bounds\n") + return + } + + # Get reference pixel value and replacement value. + buf = imgs2r (im, x, x, y, y) + ival = Memr[buf] + oval = EP_VALUE(ep) + minv = EP_MINVALUE(ep) + maxv = EP_MAXVALUE(ep) + if (IS_INDEFR(minv)) + minv = -MAX_REAL + if (IS_INDEFR(maxv)) + minv = MAX_REAL + + # This requires two passes to fit into the subraster model. + # First pass finds the limits of the change and the second + # makes the change. + + x1 = x+1; x2 = x-1; y1 = y+1; y2 = y-1 + do j = 1, nl { + buf = imgs2r (im, 1, nc, j, j) + switch (key) { + case '=': + do i = 1, nc { + val = Memr[buf+i-1] + if (val != ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '<': + do i = 1, nc { + val = Memr[buf+i-1] + if (val > ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + case '>': + do i = 1, nc { + val = Memr[buf+i-1] + if (val < ival || val == oval || val < minv || val > maxv) + next + x1 = min (x1, i) + x2 = max (x2, i) + y1 = min (y1, j) + y2 = max (y2, j) + } + } + } + + # No pixels to change. + if (x2 < x1 || y2 < y1) + return + + # Set the rasters and change the pixels. + EP_X1(ep) = x1 + EP_X2(ep) = x2 + EP_Y1(ep) = y1 + EP_Y2(ep) = y2 + EP_NX(ep) = EP_X2(ep) - EP_X1(ep) + 1 + EP_NY(ep) = EP_Y2(ep) - EP_Y1(ep) + 1 + EP_NPTS(ep) = EP_NX(ep) * EP_NY(ep) + + EP_OUTDATA(ep) = imps2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + EP_INDATA(ep) = imgs2r (im, EP_X1(ep), EP_X2(ep), EP_Y1(ep), + EP_Y2(ep)) + + buf = EP_OUTDATA(ep) + call amovr (Memr[EP_INDATA(ep)], Memr[buf], EP_NPTS(ep)) + switch (key) { + case '=': + do i = 1, EP_NPTS(ep) { + val = Memr[buf] + if (val == ival && val >= minv && val <= maxv) + Memr[buf] = oval + buf = buf + 1 + } + case '<': + do i = 1, EP_NPTS(ep) { + val = Memr[buf] + if (val <= ival && val >= minv && val <= maxv) + Memr[buf] = oval + buf = buf + 1 + } + case '>': + do i = 1, EP_NPTS(ep) { + val = Memr[buf] + if (val >= ival && val >= minv && val <= maxv) + Memr[buf] = oval + buf = buf + 1 + } + } +end + diff --git a/pkg/images/tv/imedit/epsearch.x b/pkg/images/tv/imedit/epsearch.x new file mode 100644 index 00000000..814d9a3b --- /dev/null +++ b/pkg/images/tv/imedit/epsearch.x @@ -0,0 +1,90 @@ +include +include "epix.h" + +# EP_SEARCH -- Search input data for maximum or minimum pixel in search radius. +# Return the new aperture positions. The magnitude of the search radius +# defines the range to be searched (bounded by the raster dimension) and +# the sign of the radius determines whether a minimum or maximum is sought. + +procedure ep_search (ep, data, nx, ny, ap, xa, ya, xb, yb) + +pointer ep # EPIX pointer +real data[nx,ny] # Subraster +int nx, ny # Subraster size +int ap # Aperture type +int xa, ya, xb, yb # Aperture (initial and final) + +real xc, yc, search2, dj2, r2, dmax +int i, j, i1, i2, j1, j2, imax, jmax + +begin + if (EP_SEARCH(ep) == 0.) + return + + search2 = abs (EP_SEARCH(ep)) + + xa = xa - EP_X1(ep) + 1 + xb = xb - EP_X1(ep) + 1 + xc = (xa + xb) / 2. + i1 = max (1., xc - search2) + i2 = min (real(nx), xc + search2) + imax = nint (xc) + + ya = ya - EP_Y1(ep) + 1 + yb = yb - EP_Y1(ep) + 1 + yc = (ya + yb) / 2. + j1 = max (1., yc - search2) + j2 = min (real(ny), yc + search2) + jmax = nint (yc) + + dmax = data[imax,jmax] + switch (ap) { + case 1: + search2 = EP_SEARCH(ep) ** 2 + do j = j1, j2 { + dj2 = (j - yc) ** 2 + do i = i1, i2 { + r2 = dj2 + (i - xc) ** 2 + if (r2 > search2) + next + + if (EP_SEARCH(ep) > 0.) { + if (data[i,j] > dmax) { + dmax = data[i,j] + imax = i + jmax = j + } + } else { + if (data[i,j] < dmax) { + dmax = data[i,j] + imax = i + jmax = j + } + } + } + } + default: + do j = j1, j2 { + do i = i1, i2 { + if (EP_SEARCH(ep) > 0.) { + if (data[i,j] > dmax) { + dmax = data[i,j] + imax = i + jmax = j + } + } else { + if (data[i,j] < dmax) { + dmax = data[i,j] + imax = i + jmax = j + } + } + } + } + } + + xa = xa + (imax - xc) + EP_X1(ep) - 1 + xb = xb + (imax - xc) + EP_X1(ep) - 1 + ya = ya + (jmax - yc) + EP_Y1(ep) - 1 + yb = yb + (jmax - yc) + EP_Y1(ep) - 1 +end diff --git a/pkg/images/tv/imedit/epsetpars.x b/pkg/images/tv/imedit/epsetpars.x new file mode 100644 index 00000000..4101ff5a --- /dev/null +++ b/pkg/images/tv/imedit/epsetpars.x @@ -0,0 +1,75 @@ +include +include "epix.h" + +# EP_SETPARS -- Set the parameter values in the EPIX structure. +# If a logfile is given record selected parameters. + +procedure ep_setpars (ep) + +pointer ep # EPIX structure + +int fd, clgeti(), btoi(), clgwrd(), nowhite(), open() +char clgetc() +bool clgetb() +real clgetr() +pointer sp, aperture, logfile +errchk open + +begin + call smark (sp) + call salloc (aperture, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + + EP_ANGH(ep) = clgetr ("angh") + EP_ANGV(ep) = clgetr ("angv") + EP_APERTURE(ep) = clgwrd ("aperture", Memc[aperture], SZ_FNAME, APTYPES) + EP_AUTODISPLAY(ep) = btoi (clgetb ("autodisplay")) + EP_AUTOSURFACE(ep) = btoi (clgetb ("autosurface")) + EP_BUFFER(ep) = clgetr ("buffer") + EP_DEFAULT(ep) = clgetc ("default") + EP_DISPLAY(ep) = btoi (clgetb ("display")) + EP_FIXPIX(ep) = btoi (clgetb ("fixpix")) + EP_RADIUS(ep) = clgetr ("radius") + EP_SEARCH(ep) = clgetr ("search") + EP_SIGMA(ep) = clgetr ("sigma") + EP_VALUE(ep) = clgetr ("value") + EP_MINVALUE(ep) = clgetr ("minvalue") + EP_MAXVALUE(ep) = clgetr ("maxvalue") + EP_WIDTH(ep) = clgetr ("width") + EP_XORDER(ep) = clgeti ("xorder") + EP_YORDER(ep) = clgeti ("yorder") + call clgstr ("command", EP_COMMAND(ep), EP_SZLINE) + call clgstr ("graphics", EP_GRAPHICS(ep), EP_SZFNAME) + + if (EP_LOGFD(ep) != NULL) + call close (EP_LOGFD(ep)) + EP_LOGFD(ep) = NULL + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + if (nowhite (Memc[logfile], Memc[logfile], SZ_FNAME) > 0) { + iferr { + EP_LOGFD(ep) = open (Memc[logfile], APPEND, TEXT_FILE) + fd = EP_LOGFD(ep) + call fprintf (fd, ":aperture %s\n") + call pargstr (Memc[aperture]) + call fprintf (fd, ":search %g\n") + call pargr (EP_SEARCH(ep)) + call fprintf (fd, ":radius %g\n") + call pargr (EP_RADIUS(ep)) + call fprintf (fd, ":buffer %g\n") + call pargr (EP_BUFFER(ep)) + call fprintf (fd, ":width %g\n") + call pargr (EP_WIDTH(ep)) + call fprintf (fd, ":value %g\n") + call pargr (EP_VALUE(ep)) + call fprintf (fd, ":sigma %g\n") + call pargr (EP_SIGMA(ep)) + call fprintf (fd, ":xorder %d\n") + call pargi (EP_XORDER(ep)) + call fprintf (fd, ":yorder %d\n") + call pargi (EP_YORDER(ep)) + } then + call erract (EA_WARN) + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imedit/epstatistics.x b/pkg/images/tv/imedit/epstatistics.x new file mode 100644 index 00000000..c7f075ea --- /dev/null +++ b/pkg/images/tv/imedit/epstatistics.x @@ -0,0 +1,147 @@ +include "epix.h" + +# EP_STATISTICS -- Compute and print statistics for the input aperture. + +procedure ep_statistics (ep, ap, xa, ya, xb, yb, box) + +pointer ep # EPIX structure +int ap # Aperture type +int xa, ya, xb, yb # Aperture coordinates +int box # Print box? + +int i, x1, x2, y1, y2 +pointer mask, x, y, w, gs + +begin + i = max (5., abs (EP_SEARCH(ep))+EP_BUFFER(ep)+EP_WIDTH(ep)+1) + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, xb) - i + y2 = max (ya, yb) + i + EP_OUTDATA(ep) = NULL + call ep_gindata (ep, x1, x2, y1, y2) + if (EP_INDATA(ep) != NULL) { + call malloc (mask, EP_NPTS(ep), TY_INT) + call malloc (x, EP_NPTS(ep), TY_REAL) + call malloc (y, EP_NPTS(ep), TY_REAL) + call malloc (w, EP_NPTS(ep), TY_REAL) + + call ep_search (ep, Memr[EP_INDATA(ep)], EP_NX(ep), + EP_NY(ep), ap, xa, ya, xb, yb) + call ep_mask (ep, mask, ap, xa, ya, xb, yb) + call ep_gsfit (ep, Memr[EP_INDATA(ep)], Memi[mask], + Memr[x], Memr[y], Memr[w], EP_NX(ep), EP_NY(ep), gs) + call ep_statistics1 (Memr[EP_INDATA(ep)], Memi[mask], + EP_NX(ep), EP_NY(ep), EP_X1(ep), EP_Y1(ep), + (xa+xb)/2, (ya+yb)/2, gs) + if (box == YES) + call ep_box (Memr[EP_INDATA(ep)], EP_NX(ep), EP_NY(ep), + EP_X1(ep), EP_Y1(ep), xa, ya, xb, yb) + + call mfree (mask, TY_INT) + call mfree (x, TY_REAL) + call mfree (y, TY_REAL) + call mfree (w, TY_REAL) + call gsfree (gs) + } +end + + +# EP_STATISTICS1 -- Compute and print statistics. + +procedure ep_statistics1 (data, mask, nx, ny, x1, y1, x, y, gs) + +real data[nx,ny] # Input data subraster +int mask[nx,ny] # Mask subraster +int nx, ny # Size of subraster +int x1, y1 # Origin of subraster +int x, y # Center of object +pointer gs # GSURFIT pointer + +int i, j, area, nsky +real flux, sky, sigma, d, gseval() + +begin + flux = 0. + area = 0 + sky = 0. + sigma = 0. + nsky = 0 + + do j = 1, ny { + do i = 1, nx { + if (mask[i,j] == 1) { + d = data[i,j] + if (gs != NULL) + d = d - gseval (gs, real (i), real (j)) + flux = flux + d + area = area + 1 + } else if (mask[i,j] == 2) { + d = data[i,j] - gseval (gs, real (i), real (j)) + sky = sky + data[i,j] + sigma = sigma + d * d + nsky = nsky + 1 + } + } + } + + call printf ("x=%d y=%d z=%d mean=%g area=%d") + call pargi (x) + call pargi (y) + call pargr (data[x-x1+1,y-y1+1]) + call pargr (flux / area) + call pargi (area) + + if (nsky > 0) { + call printf (" sky=%g sigma=%g nsky=%d") + call pargr (sky / nsky) + call pargr (sqrt (sigma / nsky)) + call pargi (nsky) + } + + call printf ("\n") +end + + +# EP_BOX -- Print box of pixel values. + +procedure ep_box (data, nx, ny, xo, yo, xa, ya, xb, yb) + +real data[nx,ny] # Input data subraster +int nx, ny # Size of subraster +int xo, yo # Origin of subraster +int xa, ya, xb, yb # Aperture + +int i, j, x1, x2, y1, y2, x, y + +begin + x1 = min (xa, xb) + x2 = max (xa, xb) + y1 = min (ya, yb) + y2 = max (ya, yb) + if (x2 - x1 + 1 <= 10) { + x1 = max (xo, x1 - 1) + x2 = min (xo + nx - 1, x2 + 1) + } + y1 = max (yo, y1 - 1) + y2 = min (yo + ny - 1, y2 + 1) + + call printf ("%4w") + do x = x1, x2 { + call printf (" %4d ") + call pargi (x) + } + call printf ("\n") + + do y = y2, y1, -1 { + call printf ("%4d") + call pargi (y) + j = y - yo + 1 + do x = x1, x2 { + i = x - xo + 1 + call printf (" %5g") + call pargr (data[i,j]) + } + call printf ("\n") + } +end diff --git a/pkg/images/tv/imedit/epsurface.x b/pkg/images/tv/imedit/epsurface.x new file mode 100644 index 00000000..289c814f --- /dev/null +++ b/pkg/images/tv/imedit/epsurface.x @@ -0,0 +1,46 @@ +define DUMMY 6 + +# EP_SURFACE -- Draw a perspective view of a surface. The altitude +# and azimuth of the viewing angle are variable. + +procedure ep_surface(gp, data, ncols, nlines, angh, angv) + +pointer gp # GIO pointer +real data[ncols,nlines] # Surface data to be plotted +int ncols, nlines # Dimensions of surface +real angh, angv # Orientation of surface (degrees) + +int wkid +pointer sp, work + +int first +real vpx1, vpx2, vpy1, vpy2 +common /frstfg/ first +common /noaovp/ vpx1, vpx2, vpy1, vpy2 + +begin + call smark (sp) + call salloc (work, 2 * (2 * ncols * nlines + ncols + nlines), TY_REAL) + + # Initialize surface common blocks + first = 1 + call srfabd() + + # Define viewport. + call ggview (gp, vpx1, vpx2, vpy1, vpy2) + + # Link GKS to GIO + wkid = 1 + call gopks (STDERR) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call ezsrfc (data, ncols, nlines, angh, angv, Memr[work]) + + call gdawk (wkid) + # We don't want to close the GIO pointer. + #call gclwk (wkid) + call gclks () + + call sfree (sp) +end diff --git a/pkg/images/tv/imedit/imedit.key b/pkg/images/tv/imedit/imedit.key new file mode 100644 index 00000000..211ad94c --- /dev/null +++ b/pkg/images/tv/imedit/imedit.key @@ -0,0 +1,84 @@ + IMEDIT CURSOR KEYSTROKE COMMANDS + + ? Print help + : Colon commands (see below) + Statistics + g Surface graph + i Initialize (start over without saving changes) + q Quit and save changes + p Print box of pixel values and statistics + r Redraw image display + s Surface plot at cursor + t Toggle between minimum and maximum search + + Increase radius by one + - Decrease radius by one + I Interrupt task immediately + Q Quit without saving changes + +The following editing options are available. Rectangular and line regions +are specified with two positions and aperture regions are specified by +one position. The current aperture type (circular or square) is used +in the latter case. The move option takes two positions, the position +to move from and the position to move to. + + a Background replacement (rectangle) + b Background replacement (aperture) + c Column interpolation (rectangle) + d Constant value substitution (rectangle) + e Constant value substitution (aperture) + f Interpolation across line (line) + j Replace with input data (rectangle) + k Replace with input data (aperture) + l Line interpolation (rectangle) + m Copy by replacement (aperture) + n Copy by addition (aperture) + u Undo last change (see also 'i', 'j', and 'k') + v Constant value substitution (vector) + = Constant value substitution of pixels equal + to pixel at the cursor position + < Constant value substitution of pixels less than or equal + to pixel at the cursor position + > Constant value substitution of pixels greater than or equal + to pixel at the cursor position + +When the image display provides a fill option then the effect of zoom +and roam is provided by loading image sections. This is a temporary +mechanism which will eventually be replaced by a more sophisticated +image display interface. + + E Exapnd image display + P Pan image display + R Redraw image display + Z Zoom image display + 0 Redraw image display with no zoom + 1-9 Shift display + + + IMEDIT COLON COMMANDS + +The colon either print the current value of a parameter when there is +no value or set the parameter to the specified value. + +angh [value] Horizontal viewing angle (degrees) for surface plots +angv [value] Vertical viewing angle (degrees) for surface plots +aperture [type] Aperture type (circular|square) +autodisplay [yes|no] Automatic image display? +autosurface [yes|no] Automatic surface plots? +buffer [value] Background buffer width +command [string] Display command +display [yes|no] Display image? +eparam Edit parameters +graphics [device] Graphics device +input [image] New input image to edit (output is same as input) +output [image] New output image name +radius [value] Aperture radius +search [value] Search radius +sigma [value] Noise sigma (INDEF for histrogram replacement) +value [value] Constant substitution value +minvalue [value] Minimum value for modification (INDEF=minimum) +maxvalue [value] Maximum value for modification (INDEF=maximum) +width [value] Background annulus width +write [name] Write changes to name (default current output name) +xorder [value] X order for background fitting +yorder [value] Y order for background fitting + diff --git a/pkg/images/tv/imedit/mkpkg b/pkg/images/tv/imedit/mkpkg new file mode 100644 index 00000000..438a8752 --- /dev/null +++ b/pkg/images/tv/imedit/mkpkg @@ -0,0 +1,38 @@ +# IMEDIT + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +generic: + $ifolder (epreplace.x, epreplace.gx) + $generic -k epreplace.gx -o epreplace.x + $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + epbackground.x epix.h + epcol.x epix.h + epcolon.x epix.h + epconstant.x epix.h + epdisplay.x epix.h + epdosurface.x epix.h + epgcur.x epix.h + epgdata.x epix.h + epgsfit.x epix.h + epimcopy.x + epinput.x epix.h + epline.x epix.h + epmask.x epix.h + epmove.x epix.h + epnoise.x + epreplace.x epix.h + epsearch.x epix.h + epsetpars.x epix.h + epstatistics.x epix.h + epsurface.x + t_imedit.x epix.h + ; diff --git a/pkg/images/tv/imedit/t_imedit.x b/pkg/images/tv/imedit/t_imedit.x new file mode 100644 index 00000000..984ce86b --- /dev/null +++ b/pkg/images/tv/imedit/t_imedit.x @@ -0,0 +1,305 @@ +include +include +include "epix.h" + +define HELP "imedit_help$" +define PROMPT "imedit options" + +# T_IMEDIT -- Edit image pixels. +# This task provides selection of pixels to be edit via cursor or file +# input. The regions to be edited may be defined as a rectangle or a +# center and radius for a circular or square aperture. The replacement +# options include constant substitution, background substitution, column +# or line interpolation, and moving one region to another. In addition +# this task can be used to select and display regions in surface perspective +# and to print statistics. The image display interface temporarily +# used simple calls to a user specified display task (such as TV.DISPLAY). +# The editing is done in a temporary image buffer. The commands which +# alter the input image may be logged if a log file is given. + +procedure t_imedit () + +int inlist # List of input images +int outlist # List of output images + +int i, key, ap, xa, ya, xb, yb, x1, x2, y1, y2 +int change, changes, newdisplay, newimage +bool erase +pointer sp, ep, cmd, temp +pointer im + +bool streq() +pointer immap(), imgl2r(), impl2r() +int imtopenp(), imtlen(), imtgetim(), imaccess(), ep_gcur() +errchk immap, imdelete, ep_imcopy, ep_setpars, imgl2r, impl2r + +define newim_ 99 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Allocate and initialize imedit descriptor. + call salloc (ep, EP_LEN, TY_STRUCT) + call aclri (Memi[ep], EP_LEN) + + # Check the input and output image lists have proper format. + inlist = imtopenp ("input") + outlist = imtopenp ("output") + if (imtlen (outlist) > 0 && imtlen (outlist) != imtlen (inlist)) + call error (1, "Input and output lists are not the same length") + + # Set the rest of the task parameters. + call ep_setpars (ep) + + # Repeat on each input image. + while (imtgetim (inlist, EP_INPUT(ep), EP_SZFNAME) != EOF) { + if (imtgetim (outlist, EP_OUTPUT(ep), EP_SZFNAME) == EOF) + call strcpy (EP_INPUT(ep), EP_OUTPUT(ep), EP_SZFNAME) + else if (imaccess (EP_OUTPUT(ep), READ_ONLY) == YES) { + call eprintf ("%s: Output image %s exists\n") + call pargstr (EP_INPUT(ep)) + call pargstr (EP_OUTPUT(ep)) + next + } + + # The editing takes place in a temporary editing image buffer. +newim_ call strcpy (EP_OUTPUT(ep), EP_WORK(ep), EP_SZFNAME) + call xt_mkimtemp (EP_OUTPUT(ep), EP_WORK(ep), EP_OUTPUT(ep), + EP_SZFNAME) + iferr (call ep_imcopy (EP_INPUT(ep), EP_WORK(ep))) { + call erract (EA_WARN) + next + } + + EP_IM(ep) = immap (EP_WORK(ep), READ_WRITE, 0) + EP_INDATA(ep) = NULL + EP_OUTDATA(ep) = NULL + + if (EP_LOGFD(ep) != NULL) { + call fprintf (EP_LOGFD(ep), "# Input image %s\n") + call pargstr (EP_INPUT(ep)) + } + + if (EP_DISPLAY(ep) == YES) { + key = '0' + call ep_zoom (ep, xa, ya, xb, yb, key, erase) + call ep_command (ep, EP_WORK(ep), erase) + } + + + # Enter the cursor loop. The apertures and commands are + # returned by the EP_GCUR procedure. + + newimage = NO + changes = 0 + while (ep_gcur (ep,ap,xa,ya,xb,yb,key,Memc[cmd],SZ_LINE) != EOF) { + newdisplay = NO + change = NO + + iferr { + switch (key) { + case '?': # Print help + call pagefile (HELP, PROMPT) + case ':': # Process colon commands + call ep_colon (ep, Memc[cmd], newimage) + if (newimage == YES) + break + case 'a', 'b': # Background replacement + call ep_background (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'c': # Column interpolation + call ep_col (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'd', 'e', 'v': # Constant value + call ep_constant (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'f': # Diagonal aperture + if (ap == APCDIAG) + call ep_col (ep, ap, xa, ya, xb, yb) + else + call ep_line (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case '=', '<', '>': # Replace + if (IM_PIXTYPE(EP_IM(ep)) == TY_INT) + call ep_replacei (ep, xa, ya, key) + else + call ep_replacer (ep, xa, ya, key) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'i': # Initialize + call imunmap (EP_IM(ep)) + goto newim_ + case 'j', 'k': # Replace with input + call ep_input (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'l': # Line interpolation + call ep_line (ep, ap, xa, ya, xb, yb) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'm', 'n': # Move + i = ep_gcur (ep, ap, x1, y1, x2, y2, key, + Memc[cmd],SZ_LINE) + call ep_move (ep, ap, xa, ya, xb, yb, x1, y1, x2, y2, + key) + if (EP_OUTDATA(ep) != NULL) { + change = YES + changes = changes + 1 + } + case 'g': # Surface graph + call ep_dosurface (ep) + case ' ': # Statistics + call ep_statistics (ep, ap, xa, ya, xb, yb, NO) + case 'p': + call ep_statistics (ep, ap, xa, ya, xb, yb, YES) + case 't': + EP_SEARCH(ep) = -EP_SEARCH(ep) + call ep_colon (ep, "search", newimage) + case '+': + EP_RADIUS(ep) = EP_RADIUS(ep) + 1. + call ep_colon (ep, "radius", newimage) + case '-': + EP_RADIUS(ep) = max (0., EP_RADIUS(ep) - 1.) + call ep_colon (ep, "radius", newimage) + case 's': # Surface plot + i = max (5., + abs (EP_SEARCH(ep))+EP_BUFFER(ep)+EP_WIDTH(ep)+1) + x1 = min (xa, xb) - i + x2 = max (xa, xb) + i + y1 = min (ya, yb) - i + y2 = max (ya, yb) + i + call ep_gindata (ep, x1, x2, y1, y2) + EP_OUTDATA(ep) = NULL + call ep_dosurface (ep) + case 'q': # Quit and save + case 'u': # Undo + if (EP_OUTDATA(ep) != NULL && EP_INDATA(ep) != NULL) { + call malloc (temp, EP_NPTS(ep), TY_REAL) + call amovr (Memr[EP_OUTDATA(ep)], Memr[temp], + EP_NPTS(ep)) + call amovr (Memr[EP_INDATA(ep)], + Memr[EP_OUTDATA(ep)], EP_NPTS(ep)) + call amovr (Memr[temp], Memr[EP_INDATA(ep)], + EP_NPTS(ep)) + call mfree (temp, TY_REAL) + change = YES + } else + call eprintf ("Can't undo last change\007\n") + case 'r', 'E', 'P', 'R', 'Z', '0', '1', '2', '3', '4', '5', + '6', '7', '8', '9': + if (EP_DISPLAY(ep) == YES) { + call ep_zoom (ep, xa, ya, xb, yb, key, erase) + newdisplay = YES + } + case 'Q': # Quit and no save + changes = 0 + case 'I': # Immediate interrupt + call imdelete (EP_WORK(ep)) + call fatal (1, "Interrupt") + default: + call printf ("\007") + } + } then + call erract (EA_WARN) + + if (key == 'q' || key == 'Q') + break + + if (change == YES && EP_AUTOSURFACE(ep) == YES) + call ep_dosurface (ep) + + if (change == YES && EP_AUTODISPLAY(ep) == YES) + newdisplay = YES + if (newdisplay == YES && EP_DISPLAY(ep) == YES) + call ep_display (ep, EP_WORK(ep), erase) + + # Log certain commands. Note that this is done after + # centering. + if (EP_LOGFD(ep) != NULL) { + switch (key) { + case 'a', 'c', 'd', 'f', 'j', 'l', 'v': + call fprintf (EP_LOGFD(ep), "%d %d 1 %c\n") + call pargi (xa) + call pargi (ya) + call pargi (key) + call fprintf (EP_LOGFD(ep), "%d %d 1 %c\n") + call pargi (xb) + call pargi (yb) + call pargi (key) + case 'b', 'e', 'k': + call fprintf (EP_LOGFD(ep), "%d %d 1 %c\n") + call pargi ((xa+xb)/2) + call pargi ((ya+yb)/2) + call pargi (key) + case 'u': + if (EP_OUTDATA(ep) != NULL) { + call fprintf (EP_LOGFD(ep), "%c\n") + call pargi (key) + } + case 'm', 'n': + call fprintf (EP_LOGFD(ep), "%d %d 1 %c\n") + call pargi ((xa+xb)/2) + call pargi ((ya+yb)/2) + call pargi (key) + call fprintf (EP_LOGFD(ep), "%d %d 1 %c\n") + call pargi ((x1+x2)/2) + call pargi ((y1+y2)/2) + call pargi (key) + } + } + } + + call imunmap (EP_IM(ep)) + # Only create the output if the input has been changed. + if (changes > 0) { + if (streq (EP_INPUT(ep), EP_OUTPUT(ep))) { + EP_IM(ep) = immap (EP_OUTPUT(ep), READ_WRITE, 0) + im = immap (EP_WORK(ep), READ_ONLY, 0) + do i = 1, IM_LEN(EP_IM(ep),2) + call amovr (Memr[imgl2r(im,i)], + Memr[impl2r(EP_IM(ep),i)], IM_LEN(im,1)) + call imunmap (im) + call imunmap (EP_IM(ep)) + call imdelete (EP_WORK(ep)) + } else { + if (imaccess (EP_OUTPUT(ep), READ_ONLY) == YES) + call imdelete (EP_OUTPUT(ep)) + call imrename (EP_WORK(ep), EP_OUTPUT(ep)) + } + } else + call imdelete (EP_WORK(ep)) + + # Check for a new image based on a colon command. This case + # always uses the input image name as output. + if (newimage == YES) { + call strcpy (EP_INPUT(ep), EP_OUTPUT(ep), EP_SZFNAME) + goto newim_ + } + } + + # Finish up. + if (EP_LOGFD(ep) != NULL) + call close (EP_LOGFD(ep)) + call imtclose (inlist) + call imtclose (outlist) + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine.par b/pkg/images/tv/imexamine.par new file mode 100644 index 00000000..fc409b45 --- /dev/null +++ b/pkg/images/tv/imexamine.par @@ -0,0 +1,22 @@ +input,s,a,,,,images to be examined +output,s,h,"",,,output root image name +ncoutput,i,h,101,1,,Number of columns in image output +nloutput,i,h,101,1,,Number of lines in image output +frame,i,q,1,1,,display frame +image,s,q,,,,image name +logfile,s,h,"",,,logfile +keeplog,b,h,no,,,log output results +defkey,s,h,"a",,,default key for cursor list input +autoredraw,b,h,yes,,,automatically redraw graph +allframes,b,h,yes,,,use all frames for displaying new images +nframes,i,h,0,,,number of display frames (0 to autosense) +ncstat,i,h,5,1,,number of columns for statistics +nlstat,i,h,5,1,,number of lines for statistics +graphcur,*gcur,h,"",,,graphics cursor input +imagecur,*imcur,h,"",,,image display cursor input +wcs,s,h,"logical",,,Coordinate system +xformat,s,h,"",,,X axis coordinate format +yformat,s,h,"",,,Y axis coordinate format +graphics,s,h,"stdgraph",,,graphics device +display,s,h,"display(image='$1',frame=$2)",,,display command template +use_display,b,h,yes,,,enable direct display interaction diff --git a/pkg/images/tv/imexamine/iecimexam.x b/pkg/images/tv/imexamine/iecimexam.x new file mode 100644 index 00000000..1bcc6d65 --- /dev/null +++ b/pkg/images/tv/imexamine/iecimexam.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + +# IE_CIMEXAM -- Column plot +# If the input column is INDEF use the last column. + +procedure ie_cimexam (gp, mode, ie, x) + +pointer gp # GIO pointer +int mode # Mode +pointer ie # Structure pointer +real x # Column + +real xavg, junk +int i, x1, x2, y1, y2, nx, ny, npts +pointer sp, title, im, data, ptr, xp, yp + +real asumr() +int clgpseti() +pointer clopset(), ie_gimage(), ie_gdata() +errchk clcpset, clopset + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + IE_PP(ie) = clopset ("cimexam") + + if (!IS_INDEF(x)) + IE_X1(ie) = x + + nx = clgpseti (IE_PP(ie), "naverage") + x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 + x2 = IE_X1(ie) + nx / 2 + 0.5 + xavg = (x1 + x2) / 2. + y1 = INDEFI + y2 = INDEFI + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + call smark (sp) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (xp, ny, TY_REAL) + + do i = 1, ny + call ie_mwctran (ie, xavg, real(i), junk, Memr[xp+i-1]) + + if (nx > 1) { + ptr = data + call salloc (yp, ny, TY_REAL) + do i = 1, ny { + Memr[yp+i-1] = asumr (Memr[ptr], nx) + ptr = ptr + nx + } + call adivkr (Memr[yp], real (nx), Memr[yp], ny) + } else + yp = data + + call sprintf (Memc[title], IE_SZTITLE, "%s: Columns %d - %d\n%s") + call pargstr (IE_IMNAME(ie)) + call pargi (x1) + call pargi (x2) + call pargstr (IM_TITLE(im)) + + call ie_graph (gp, mode, IE_PP(ie), Memc[title], Memr[xp], + Memr[yp], ny, IE_YLABEL(ie), IE_YFORMAT(ie)) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iecolon.x b/pkg/images/tv/imexamine/iecolon.x new file mode 100644 index 00000000..72925500 --- /dev/null +++ b/pkg/images/tv/imexamine/iecolon.x @@ -0,0 +1,1038 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + +# List of boundary types, marker types, and colon commands. + +define BTYPES "|constant|nearest|reflect|wrap|project|" +define MTYPES "|point|box|plus|cross|circle|hebar|vebar|hline|vline|diamond|" +define CMDS "|angh|angv|background|banner|boundary|box|buffer|ceiling|\ + |center|constant|dashpat|defkey|eparam|fill|floor|interval|\ + |label|logfile|logx|logy|magzero|majrx|majry|marker|minrx|\ + |minry|naverage|ncolumns|ncontours|ncstat|nhi|nlines|nlstat|\ + |pointmode|radius|round|rplot|select|szmarker|ticklabels|\ + |title|width|x|xlabel|xorder|y|ylabel|yorder|zero|unlearn|\ + |autoredraw|nbins|z1|z2|autoscale|top_closed|allframes|wcs|\ + |xformat|yformat|fitplot|sigma|axes|fittype|beta|iterations|\ + |output|ncoutput|nloutput|" + +define ANGH 1 +define ANGV 2 +define BACKGROUND 3 +define BANNER 4 +define BOUNDARY 5 +define BOX 6 +define BUFFER 7 +define CEILING 8 + +define CENTER 10 +define CONSTANT 11 +define DASHPAT 12 +define DEFKEY 13 +define EPARAM 14 +define FILL 15 +define FLOOR 16 +define INTERVAL 17 + +define LABEL 19 +define LOGFILE 20 +define LOGX 21 +define LOGY 22 +define MAGZERO 23 +define MAJRX 24 +define MAJRY 25 +define MARKER 26 +define MINRX 27 + +define MINRY 29 +define NAVERAGE 30 +define NCOLUMNS 31 +define NCONTOURS 32 +define NCSTAT 33 +define NHI 34 +define NLINES 35 +define NLSTAT 36 + +define POINTMODE 38 +define RADIUS 39 +define ROUND 40 +define RPLOT 41 +define SELECT 42 +define SZMARKER 43 +define TICKLABELS 44 + +define TITLE 46 +define WIDTH 47 +define X 48 +define XLABEL 49 +define XORDER 50 +define Y 51 +define YLABEL 52 +define YORDER 53 +define ZERO 54 +define UNLEARN 55 + +define AUTOREDRAW 57 +define NBINS 58 +define Z1 59 +define Z2 60 +define AUTOSCALE 61 +define TOP_CLOSED 62 +define ALLFRAMES 63 +define WCS 64 + +define XFORMAT 66 +define YFORMAT 67 +define FITPLOT 68 +define SIGMA 69 +define AXES 70 +define FITTYPE 71 +define BETA 72 +define ITERATIONS 73 + +define OUTPUT 75 +define NCOUTPUT 76 +define NLOUTPUT 77 + + +# IE_COLON -- Respond to colon commands. + +procedure ie_colon (ie, cmdstr, gp, redraw) + +pointer ie # IMEXAM data structure +char cmdstr[ARB] # Colon command +pointer gp # GIO pointer +int redraw # Redraw graph? + +char gtype +bool bval +real rval1 +int ival, ncmd +pointer sp, cmd, pp + +bool clgetb(), clgpsetb() +char clgetc() +real clgetr(), clgpsetr() +int nscan(), strdic(), clgeti() +pointer clopset() +errchk clopset, clppsetb, clppsetr, clputb, clputi, clputr + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Scan the command string and get the first word. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + if (ncmd == 0) { + call printf ("Unrecognized or ambiguous command\007") + call sfree (sp) + return + } + + gtype = IE_GTYPE(ie) + pp = IE_PP(ie) + + # Special optimization for the a key. + switch (ncmd) { + case BACKGROUND, CENTER, NAVERAGE, RPLOT, XORDER, WIDTH: + if (IE_LASTKEY(ie) == 'a') { + gtype = 'r' + pp = clopset ("rimexam") + } + if (IE_LASTKEY(ie) == ',') { + gtype = '.' + pp = clopset ("rimexam") + } + } + + # Switch on the command and possibly read further arguments. + switch (ncmd) { + case ANGH: + call gargr (rval1) + if (nscan() == 1) { + call printf ("angh %g\n") + call pargr (clgetr ("simexam.angh")) + } else { + call clputr ("simexam.angh", rval1) + if (gtype == 's') + redraw = YES + } + case ANGV: + call gargr (rval1) + if (nscan() == 1) { + call printf ("angv %g\n") + call pargr (clgetr ("simexam.angv")) + } else { + call clputr ("simexam.angv", rval1) + if (gtype == 's') + redraw = YES + } + case BACKGROUND: + switch (gtype) { + case 'j', 'k', 'r', '.': + call gargb (bval) + if (nscan() == 1) { + call printf ("background %b\n") + call pargb (clgpsetb (pp, "background")) + } else { + call clppsetb (pp, "background", bval) + if (pp == IE_PP(ie)) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case BANNER: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "banner", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case BOUNDARY: + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, BTYPES) + if (ncmd == 0) { + call printf ("Boundary types are %s\n") + call pargstr (BTYPES) + } else + call clpstr ("vimexam.boundary", Memc[cmd]) + case BOX: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "box", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case BUFFER: + call gargr (rval1) + if (nscan() == 1) { + call printf ("buffer %g\n") + call pargr (clgetr ("rimexam.buffer")) + } else { + call clputr ("rimexam.buffer", rval1) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + case CEILING: + switch (gtype) { + case 's', 'e': + call gargr (rval1) + if (nscan() == 1) { + call printf ("ceiling %g\n") + call pargr (clgpsetr (pp, "ceiling")) + } else { + call clppsetr (pp, "ceiling", rval1) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case CENTER: + switch (gtype) { + case 'j', 'k', 'r', '.': + call gargb (bval) + if (nscan() == 1) { + call printf ("center %b\n") + call pargb (clgpsetb (pp, "center")) + } else { + call clppsetb (pp, "center", bval) + if (pp == IE_PP(ie)) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case CONSTANT: + call gargr (rval1) + if (nscan() == 1) { + call printf ("constant %g\n") + call pargr (clgetr ("vimexam.constant")) + } else + call clputr ("vimexam.constant", rval1) + case DASHPAT: + call gargi (ival) + if (nscan() == 1) { + call printf ("dashpat %g\n") + call pargi (clgeti ("eimexam.dashpat")) + } else { + call clputi ("eimexam.dashpat", ival) + if (gtype == 'e') + redraw = YES + } + case DEFKEY: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call printf ("defkey %c\n") + call pargc (clgetc ("defkey")) + } else + call clputc ("defkey", Memc[cmd]) + case EPARAM: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + Memc[cmd] = gtype + + switch (Memc[cmd]) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 's', 'h', '.': + call gdeactivate (gp, 0) + switch (Memc[cmd]) { + case 'c': + call clcmdw ("eparam cimexam") + case 'j': + call clcmdw ("eparam jimexam") + case 'k': + call clcmdw ("eparam kimexam") + case 'l': + call clcmdw ("eparam limexam") + case 'r', '.': + call clcmdw ("eparam rimexam") + case 's': + call clcmdw ("eparam simexam") + case 'u', 'v': + call clcmdw ("eparam vimexam") + case 'e': + call clcmdw ("eparam eimexam") + case 'h': + call clcmdw ("eparam himexam") + } + if (Memc[cmd] == gtype) + redraw = YES + } + case FILL: + call gargb (bval) + if (nscan() == 1) { + call printf ("fill %b\n") + call pargb (clgetb ("eimexam.fill")) + } else { + call clputb ("eimexam.fill", bval) + if (gtype == 'e') + redraw = YES + } + case FLOOR: + switch (gtype) { + case 's', 'e': + call gargr (rval1) + if (nscan() == 1) { + call printf ("floor %g\n") + call pargr (clgpsetr (pp, "floor")) + } else { + call clppsetr (pp, "floor", rval1) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case INTERVAL: + call gargr (rval1) + if (nscan() == 1) { + call printf ("interval %g\n") + call pargr (clgetr ("eimexam.interval")) + } else { + call clputr ("eimexam.interval", rval1) + if (gtype == 'e') + redraw = YES + } + case LABEL: + call gargb (bval) + if (nscan() == 2) { + call clputb ("eimexam.label", bval) + if (gtype == 'e') + redraw = YES + } + + case LOGFILE: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call strcpy (IE_LOGFILE(ie), Memc[cmd], SZ_LINE) + if (IE_LOGFD(ie) == NULL) { + call printf ("logfile %s [closed]\n") + call pargstr (Memc[cmd]) + } else { + call printf ("logfile %s [open]\n") + call pargstr (Memc[cmd]) + } + } else { + call clpstr ("logfile", Memc[cmd]) + if (IE_LOGFD(ie) != NULL) { + call close (IE_LOGFD(ie)) + IE_LOGFD(ie) = NULL + } + + call clgstr ("logfile", IE_LOGFILE(ie), SZ_LINE) + if (clgetb ("keeplog")) + iferr (call ie_openlog (ie)) + call erract (EA_WARN) + } + + case LOGX: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "logx", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case LOGY: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "logy", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case MAGZERO: + call gargr (rval1) + if (nscan() == 1) { + call printf ("magzero %g\n") + call pargr (clgetr ("rimexam.magzero")) + } else { + call clputr ("rimexam.magzero", rval1) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + case AUTOREDRAW: + call gargb (bval) + if (nscan() == 1) { + call printf ("autoredraw %b\n") + call pargb (clgetb ("autoredraw")) + } else + call clputb ("autoredraw", bval) + default: + call ie_colon1 (ie, ncmd, gp, pp, gtype, redraw) + } + + if (pp != IE_PP(ie)) + call clcpset (pp) + if (redraw == YES && !clgetb ("autoredraw")) + redraw = NO + call sfree (sp) +end + + +# IE_COLON1 -- Subprocedure to get around too many strings error in xc. + +procedure ie_colon1 (ie, ncmd, gp, pp, gtype, redraw) + +pointer ie # IMEXAM data structure +int ncmd # Command number +pointer gp # GIO pointer +pointer pp # Pset pointer +char gtype # Graph type +int redraw # Redraw graph? + +int ival +real rval1, rval2 +bool bval +pointer sp, cmd, im + +real clgetr(), clgpsetr() +pointer ie_gimage() +int nscan(), strdic(), clgeti(), clgpseti() +errchk ie_gimage, clppseti + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + switch (ncmd) { + case MAJRX: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("majrx %d\n") + call pargi (clgpseti (pp, "majrx")) + } else { + call clppseti (pp, "majrx", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case MAJRY: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("majry %d\n") + call pargi (clgpseti (pp, "majry")) + } else { + call clppseti (pp, "majry", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case MARKER: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, MTYPES) + if (ncmd == 0) { + call printf ("Marker types are %s\n") + call pargstr (MTYPES) + } else { + call clppset (pp, "marker", Memc[cmd]) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case MINRX: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("minrx %d\n") + call pargi (clgpseti (pp, "minrx")) + } else { + call clppseti (pp, "minrx", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case MINRY: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("minry %d\n") + call pargi (clgpseti (pp, "minry")) + } else { + call clppseti (pp, "minry", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case NAVERAGE: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'v': + call gargi (ival) + if (nscan() == 1) { + call printf ("naverage %d\n") + call pargi (clgpseti (pp, "naverage")) + } else { + call clppseti (pp, "naverage", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case NCOLUMNS: + switch (gtype) { + case 's', 'e', 'h': + call gargi (ival) + if (nscan() == 1) { + call printf ("ncolumns %d\n") + call pargi (clgpseti (pp, "ncolumns")) + } else { + call clppseti (pp, "ncolumns", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case NCONTOURS: + call gargi (ival) + if (nscan() == 1) { + call printf ("ncontours %g\n") + call pargi (clgeti ("eimexam.ncontours")) + } else { + call clputi ("eimexam.ncontours", ival) + if (gtype == 'e') + redraw = YES + } + case NCSTAT: + call gargi (ival) + if (nscan() == 1) { + call printf ("ncstat %g\n") + call pargi (clgeti ("ncstat")) + } else + call clputi ("ncstat", ival) + case NHI: + call gargi (ival) + if (nscan() == 1) { + call printf ("nhi %g\n") + call pargi (clgeti ("eimexam.nhi")) + } else { + call clputi ("eimexam.nhi", ival) + if (gtype == 'e') + redraw = YES + } + case NLINES: + switch (gtype) { + case 's', 'e', 'h': + call gargi (ival) + if (nscan() == 1) { + call printf ("nlines %d\n") + call pargi (clgpseti (pp, "nlines")) + } else { + call clppseti (pp, "nlines", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case NLSTAT: + call gargi (ival) + if (nscan() == 1) { + call printf ("nlstat %g\n") + call pargi (clgeti ("nlstat")) + } else + call clputi ("nlstat", ival) + case POINTMODE: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "pointmode", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case RADIUS: + call gargr (rval1) + if (nscan() == 1) { + call printf ("radius %g\n") + call pargr (clgetr ("rimexam.radius")) + } else { + call clputr ("rimexam.radius", rval1) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + case ROUND: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "round", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case RPLOT: + switch (gtype) { + case 'j', 'k', 'r', '.': + call gargr (rval1) + if (nscan() == 1) { + call printf ("rplot %g\n") + call pargr (clgpsetr (pp, "rplot")) + } else { + call clppsetr (pp, "rplot", rval1) + if (pp == IE_PP(ie)) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case SELECT: + call gargi (ival) + if (nscan () > 1) { + if (IE_LIST(ie) != NULL) + IE_INDEX(ie) = ival + else + IE_NEWFRAME(ie) = ival + IE_MAPFRAME(ie) = 0 + iferr (im = ie_gimage (ie, YES)) + call erract (EA_WARN) + } + case SZMARKER: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("szmarker %d\n") + call pargi (clgpseti (pp, "szmarker")) + } else { + call clppseti (pp, "szmarker", ival) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case TICKLABELS: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + call gargb (bval) + if (nscan() == 2) { + call clppsetb (pp, "ticklabels", bval) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case TITLE: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 's', 'v', 'e', 'h', '.': + Memc[cmd] = EOS + call gargstr (Memc[cmd], SZ_LINE) + call clppset (pp, "title", Memc[cmd]) + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case WIDTH: + switch (gtype) { + case 'j', 'k', 'r', '.': + call gargr (rval1) + if (nscan() == 1) { + call printf ("width %g\n") + call pargr (clgpsetr (pp, "width")) + } else { + call clppsetr (pp, "width", rval1) + if (pp == IE_PP(ie)) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case X: + switch (gtype) { + case 'c', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargr (rval1) + call gargr (rval2) + if (nscan() < 3) { + call clppsetr (pp, "x1", INDEF) + call clppsetr (pp, "x2", INDEF) + } else { + call clppsetr (pp, "x1", rval1) + call clppsetr (pp, "x2", rval2) + } + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case XLABEL: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + Memc[cmd] = EOS + call gargstr (Memc[cmd], SZ_LINE) + call clppset (pp, "xlabel", Memc[cmd]) + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case XORDER: + switch (gtype) { + case 'j', 'k', 'r', '.': + call gargi (ival) + if (nscan() == 1) { + call printf ("xorder %d\n") + call pargi (clgpseti (pp, "xorder")) + } else { + call clppseti (pp, "xorder", ival) + if (pp == IE_PP(ie)) + redraw = YES + } + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case Y: + switch (gtype) { + case 'c', 'j', 'k', 'l', 'r', 'v', 'h', '.': + call gargr (rval1) + call gargr (rval2) + if (nscan() < 3) { + call clppsetr (pp, "y1", INDEF) + call clppsetr (pp, "y2", INDEF) + } else { + call clppsetr (pp, "y1", rval1) + call clppsetr (pp, "y2", rval2) + } + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + default: + call ie_colon2 (ie, ncmd, gp, pp, gtype, redraw) + } + + call sfree (sp) +end + + +# IE_COLON2 -- Subprocedure to get around too many strings error in xc. + +procedure ie_colon2 (ie, ncmd, gp, pp, gtype, redraw) + +pointer ie # IMEXAM data structure +int ncmd # Command number +pointer gp # GIO pointer +pointer pp # Pset pointer +char gtype # Graph type +int redraw # Redraw graph? + +int ival +real rval1 +bool bval +pointer sp, cmd + +real clgetr() +bool clgetb() +int nscan(), clgeti(), btoi(), strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + switch (ncmd) { + case YLABEL: + switch (gtype) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': + Memc[cmd] = EOS + call gargstr (Memc[cmd], SZ_LINE) + call clppset (pp, "ylabel", Memc[cmd]) + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case YORDER: + call gargi (ival) + if (nscan() == 1) { + call printf ("yorder %d\n") + call pargi (clgeti ("rimexam.yorder")) + } else { + call clputi ("rimexam.yorder", ival) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + case ZERO: + call gargr (rval1) + if (nscan() == 1) { + call printf ("zero %g\n") + call pargr (clgetr ("eimexam.zero")) + } else { + call clputr ("eimexam.zero", rval1) + if (gtype == 'e') + redraw = YES + } + case UNLEARN: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + Memc[cmd] = gtype + + switch (Memc[cmd]) { + case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 's', 'h', '.': + switch (Memc[cmd]) { + case 'c': + call clcmdw ("unlearn cimexam") + case 'j': + call clcmdw ("unlearn jimexam") + case 'k': + call clcmdw ("unlearn jimexam") + case 'l': + call clcmdw ("unlearn limexam") + case 'r', '.': + call clcmdw ("unlearn rimexam") + case 's': + call clcmdw ("unlearn simexam") + case 'u', 'v': + call clcmdw ("unlearn vimexam") + case 'e': + call clcmdw ("unlearn eimexam") + case 'h': + call clcmdw ("unlearn himexam") + } + if (Memc[cmd] == gtype) + redraw = YES + default: + call printf ("Parameter does not apply to current graph\007\n") + } + case NBINS: + call gargi (ival) + if (nscan() == 1) { + call printf ("nbins %d\n") + call pargi (clgeti ("himexam.nbins")) + } else { + call clputi ("himexam.nbins", ival) + if (gtype == 'h') + redraw = YES + } + case Z1: + call gargr (rval1) + if (nscan() == 1) { + call printf ("z1 %g\n") + call pargr (clgetr ("himexam.z1")) + } else { + call clputr ("himexam.z1", rval1) + if (gtype == 'h') + redraw = YES + } + case Z2: + call gargr (rval1) + if (nscan() == 1) { + call printf ("z2 %g\n") + call pargr (clgetr ("himexam.z2")) + } else { + call clputr ("himexam.z2", rval1) + if (gtype == 'h') + redraw = YES + } + case AUTOSCALE: + call gargb (bval) + if (nscan() == 1) { + call printf ("autoscale %b\n") + call pargb (clgetb ("himexam.autoscale")) + } else { + call clputb ("himexam.autoscale", bval) + if (gtype == 'h') + redraw = YES + } + case TOP_CLOSED: + call gargb (bval) + if (nscan() == 1) { + call printf ("top_closed %b\n") + call pargb (clgetb ("himexam.top_closed")) + } else { + call clputb ("himexam.top_closed", bval) + if (gtype == 'h') + redraw = YES + } + case ALLFRAMES: + call gargb (bval) + if (nscan() == 1) { + call printf ("allframes %b\n") + call pargb (clgetb ("allframes")) + } else { + call clputb ("allframes", bval) + IE_ALLFRAMES(ie) = btoi (bval) + } + case WCS: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call printf ("wcs %s\n") + call pargstr (IE_WCSNAME(ie)) + } else { + call strcpy (Memc[cmd], IE_WCSNAME(ie), SZ_FNAME) + call ie_mwinit (ie) + redraw = YES + } + case XFORMAT: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call clpstr ("xformat", "") + else + call clpstr ("xformat", Memc[cmd]) + case YFORMAT: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) + call clpstr ("yformat", "") + else + call clpstr ("yformat", Memc[cmd]) + case FITPLOT: + call gargb (bval) + if (nscan() == 1) { + call printf ("fitplot %b\n") + call pargb (clgetb ("rimexam.fitplot")) + } else { + call clputb ("rimexam.fitplot", bval) + if (gtype == 'r') + redraw = YES + } + case SIGMA: + call gargr (rval1) + if (nscan() == 1) { + call printf ("sigma %g\n") + call pargr (clgetr ("jimexam.sigma")) + } else { + call clputr ("jimexam.sigma", rval1) + if (gtype == 'j' || gtype == 'k') + redraw = YES + } + case AXES: + call gargb (bval) + if (nscan() == 2) { + call clputb ("simexam.axes", bval) + if (gtype == 's') + redraw = YES + } + case FITTYPE: + call gargwrd (Memc[cmd], SZ_LINE) + if (nscan() == 1) { + call clgstr ("rimexam.fittype", Memc[cmd], SZ_LINE) + call printf ("fittype %s\n") + call pargstr (Memc[cmd]) + } else { + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, + "|gaussian|moffat|") + if (ncmd == 0) { + call printf ("Profile fit types are %s\n") + call pargstr ("|gaussian|moffat|") + } else { + call clpstr ("rimexam.fittype", Memc[cmd]) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + } + case BETA: + call gargr (rval1) + if (nscan() == 1) { + call printf ("beta %g\n") + call pargr (clgetr ("rimexam.beta")) + } else { + call clputr ("rimexam.beta", rval1) + if (gtype == 'r' || gtype == '.') + redraw = YES + } + case ITERATIONS: + call gargi (ival) + if (nscan() == 1) { + call printf ("iterations %d\n") + call pargi (clgeti ("rimexam.iterations")) + } else { + call clputi ("rimexam.iterations", ival) + if (gtype == 'r') + redraw = YES + } + + case OUTPUT: + call gargwrd (Memc[cmd], SZ_FNAME) + if (nscan() == 1) { + call clgstr ("output", Memc[cmd], SZ_FNAME) + call printf ("output `%s'\n") + call pargstr (Memc[cmd]) + } else + call clpstr ("output", Memc[cmd]) + case NCOUTPUT: + call gargi (ival) + if (nscan() == 1) { + call printf ("ncoutput %g\n") + call pargi (clgeti ("ncoutput")) + } else + call clputi ("ncoutput", ival) + case NLOUTPUT: + call gargi (ival) + if (nscan() == 1) { + call printf ("nloutput %g\n") + call pargi (clgeti ("nloutput")) + } else + call clputi ("nloutput", ival) + + default: + call printf ("Ambiguous or unrecognized command\007\n") + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iedisplay.x b/pkg/images/tv/imexamine/iedisplay.x new file mode 100644 index 00000000..4015bca7 --- /dev/null +++ b/pkg/images/tv/imexamine/iedisplay.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IE_DISPLAY -- Display an image. For the sake of convenience in this +# prototype program we do this by calling a task via the cl. This is an +# interface violation which we try to mitigate by using a CL parameter to +# hide the knowledge of how to format the command (as well as make it easy +# for the user to control how images are displayed). + +procedure ie_display (ie, image, frame) + +pointer ie #I imexamine descriptor +char image[ARB] #I image to be displayed +int frame #I frame in which to display image + +int nchars +pointer sp, d_cmd, d_args, d_template, im +int gstrcpy(), strmac(), ie_getnframes() +pointer immap() + +begin + call smark (sp) + call salloc (d_cmd, SZ_LINE, TY_CHAR) + call salloc (d_args, SZ_LINE, TY_CHAR) + call salloc (d_template, SZ_LINE, TY_CHAR) + + # Verify that the named image or image section exists. + iferr (im = immap (image, READ_ONLY, 0)) { + call erract (EA_WARN) + call sfree (sp) + return + } else + call imunmap (im) + + # Get the display command template. + call clgstr ("display", Memc[d_template], SZ_LINE) + + # Construct the macro argument list, a sequence of EOS delimited + # strings terminated by a double EOS. + + call aclrc (Memc[d_args], SZ_LINE) + nchars = gstrcpy (image, Memc[d_args], SZ_LINE) + 1 + call sprintf (Memc[d_args+nchars], SZ_LINE-nchars, "%d") + call pargi (frame) + + # Expand the command template to form the CL command. + nchars = strmac (Memc[d_template], Memc[d_args], Memc[d_cmd], SZ_LINE) + + # Send the command off to the CL and wait for completion. + call clcmdw (Memc[d_cmd]) + nchars = ie_getnframes (ie) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ieeimexam.x b/pkg/images/tv/imexamine/ieeimexam.x new file mode 100644 index 00000000..059721ba --- /dev/null +++ b/pkg/images/tv/imexamine/ieeimexam.x @@ -0,0 +1,243 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "imexam.h" + + +# IE_EIMEXAM -- Contour map +# This is an interface to the NCAR CONREC routine. + +procedure ie_eimexam (gp, mode, ie, x, y) + +pointer gp # GIO pointer +int mode # Mode +pointer ie # IE pointer +real x, y # Center + +bool banner +int nset, ncontours, dashpat, nhi +int x1, x2, y1, y2, nx, ny, npts, wkid +real vx1, vx2, vy1, vy2, xs, xe, ys, ye +real interval, floor, ceiling, zero, finc, zmin, zmax +pointer sp, title, hostid, user, xlabel, ylabel, im, data, data1 + +pointer pp, clopset(), ie_gdata(), ie_gimage() +bool clgpsetb(), fp_equalr() +int clgpseti(), btoi() +real clgpsetr() + +int isizel, isizem, isizep, nrep, ncrt, ilab, nulbll, ioffd +int ioffm, isolid, nla, nlm +real xlt, ybt, side, ext, hold[5] +common /conre4/ isizel, isizem , isizep, nrep, ncrt, ilab, nulbll, + ioffd, ext, ioffm, isolid, nla, nlm, xlt, ybt, side +int first +common /conflg/ first +common /noaolb/ hold + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + pp = IE_PP(ie) + if (pp != NULL) + call clcpset (pp) + pp = clopset ("eimexam") + IE_PP(ie) = pp + + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + nx = clgpseti (pp, "ncolumns") + ny = clgpseti (pp, "nlines") + x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 + x2 = IE_X1(ie) + nx / 2 + 0.5 + y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 + y2 = IE_Y1(ie) + ny / 2 + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + xs = x1 + xe = x2 + ys = y1 + ye = y2 + + call smark (sp) + banner = false + if (mode == NEW_FILE) { + call gclear (gp) + + # Set the WCS + call gswind (gp, xs, xe, ys, ye) + + if (!clgpsetb (pp, "fill")) + call gsetr (gp, G_ASPECT, real (ny-1) / real (nx-1)) + + call gseti (gp, G_ROUND, btoi (clgpsetb (pp, "round"))) + + if (clgpsetb (pp, "box")) { + # Get number of major and minor tick marks. + call gseti (gp, G_XNMAJOR, clgpseti (pp, "majrx")) + call gseti (gp, G_XNMINOR, clgpseti (pp, "minrx")) + call gseti (gp, G_YNMAJOR, clgpseti (pp, "majry")) + call gseti (gp, G_YNMINOR, clgpseti (pp, "minry")) + + # Label tick marks on axes? + call gseti (gp, G_LABELTICKS, + btoi (clgpsetb (pp, "ticklabels"))) + + # Labels + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (hostid, SZ_LINE, TY_CHAR) + call salloc (user, SZ_LINE, TY_CHAR) + call salloc (xlabel, SZ_LINE, TY_CHAR) + call salloc (ylabel, SZ_LINE, TY_CHAR) + + banner = clgpsetb (pp, "banner") + if (banner) { + call sysid (Memc[hostid], SZ_LINE) + # We must postpone the parameter line until after conrec. + call sprintf (Memc[title], IE_SZTITLE, "%s\n\n%s") + call pargstr (Memc[hostid]) + call pargstr (IM_TITLE(im)) + } else + Memc[title] = EOS + + call clgpset (pp, "title", Memc[user], SZ_LINE) + if (Memc[user] != EOS) { + call strcat ("\n", Memc[title], IE_SZTITLE) + call strcat (Memc[user], Memc[title], IE_SZTITLE) + } + call clgpset (pp, "xlabel", Memc[xlabel], SZ_LINE) + call clgpset (pp, "ylabel", Memc[ylabel], SZ_LINE) + + call glabax (gp, Memc[title], Memc[xlabel], Memc[ylabel]) + } + } + + # First of all, intialize conrec's block data before altering any + # parameters in common. + first = 1 + call conbd + + # Set contour parameters + zero = clgpsetr (pp, "zero") + floor = clgpsetr (pp, "floor") + ceiling = clgpsetr (pp, "ceiling") + nhi = clgpseti (pp, "nhi") + dashpat = clgpseti (pp, "dashpat") + + # Resolve INDEF limits. + if (IS_INDEF (floor) || IS_INDEF (ceiling)) { + call alimr (Memr[data], npts, zmin, zmax) + if (IS_INDEF (floor)) + floor = zmin + if (IS_INDEF (ceiling)) + ceiling = zmax + } + + # Apply the zero point shift. + if (abs (zero) > EPSILON) { + call salloc (data1, npts, TY_REAL) + call asubkr (Memr[data], zero, Memr[data1], npts) + floor = floor - zero + ceiling = ceiling - zero + } else + data1 = data + + # Avoid conrec's automatic scaling. + if (floor == 0.) + floor = EPSILON + if (ceiling == 0.) + ceiling = EPSILON + + # The user can suppress the contour labelling by setting the common + # parameter "ilab" to zero. + if (btoi (clgpsetb (pp, "label")) == NO) + ilab = 0 + else + ilab = 1 + + # User can specify either the number of contours or the contour + # interval, or let conrec pick a nice number. Get params and + # encode the FINC param expected by conrec. + + ncontours = clgpseti (pp, "ncontours") + if (ncontours <= 0) { + interval = clgpsetr (pp, "interval") + if (interval <= 0) + finc = 0 + else + finc = interval + } else + finc = - abs (ncontours) + + # Open device and make contour plot. + call gopks (STDERR) + wkid = 1 + call gopwk (wkid, 6, gp) + call gacwk (wkid) + + # Make the contour plot. + nset = 1 # No conrec viewport + ioffm = 1 # No conrec box + call gswind (gp, 1., real (nx), 1., real (ny)) + call ggview (gp, vx1, vx2, vy1, vy2) + call set (vx1, vx2, vy1, vy2, 1.0, real (nx), 1.0, real (ny), 1) + call conrec (Memr[data1], nx, nx, ny, floor, + ceiling, finc, nset, nhi, -dashpat) + + call gdawk (wkid) + call gclks () + + call gswind (gp, xs, xe, ys, ye) + if (banner) { + if (fp_equalr (hold(5), 1.0)) { + call sprintf (Memc[title], IE_SZTITLE, + "%s\n%s: Contoured from %g to %g, interval = %g\n%s") + call pargstr (Memc[hostid]) + call pargstr (IE_IMNAME(ie)) + call pargr (hold(1)) + call pargr (hold(2)) + call pargr (hold(3)) + call pargstr (IM_TITLE(im)) + } else { + call sprintf (Memc[title], IE_SZTITLE, + "%s\n%s:contoured from %g to %g, interval = %g, labels scaled by %g\n%s") + call pargstr (Memc[xlabel]) + call pargstr (IE_IMNAME(ie)) + call pargr (hold(1)) + call pargr (hold(2)) + call pargr (hold(3)) + call pargr (hold(5)) + call pargstr (IM_TITLE(im)) + } + + if (Memc[user] != EOS) { + call strcat ("\n", Memc[user], IE_SZTITLE) + call strcat (Memc[user], Memc[title], IE_SZTITLE) + } + + call gseti (gp, G_DRAWAXES, NO) + call glabax (gp, Memc[title], "", "") + + } else + call gtext (gp, xs, ys, "", "") + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iegcur.x b/pkg/images/tv/imexamine/iegcur.x new file mode 100644 index 00000000..2b76cee5 --- /dev/null +++ b/pkg/images/tv/imexamine/iegcur.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imexam.h" + +# IE_GCUR -- Get IMEXAM cursor value. +# This is an interface between the standard cursor input and IMEXAM. +# It reads the appropriate cursor, determines the image index or frame +# type, makes the appropriate default coordinate conversions when using +# graphics cursor input, and gets any further cursor reads needed. +# Missing coordinates default to the last coordinates. + +int procedure ie_gcur (ie, curtype, x, y, key, strval, maxch) + +pointer ie #I IMEXAM structure +int curtype #I cursor type (0=image, 1=graphics, 2=text) +real x, y #O cursor position +int key #O keystroke value of cursor event +char strval[ARB] #O string value, if any +int maxch #I max chars out + +char ch +real x1, y1, x2, y2, dx, dy, r, cosa, sina +int temp, k[2], nitems, wcs, ip, i + +bool streq() +char clgetc() +int clgcur(), imd_gcur(), ctor(), cctoc() +errchk clgcur, imd_gcur + +begin + # Save last cursor value. + x1 = x; y1 = y + strval[1] = EOS + k[1] = clgetc ("defkey") + + # Get one or more cursor values from the desired cursor parameter. + # Check for missing coordinates and substitute the last value. + + do i = 1, 2 { + switch (curtype) { + case 'i': + nitems = imd_gcur ("imagecur", x, y, wcs, k[i], strval, maxch) + if (IS_INDEF(x)) + x = x1 + if (IS_INDEF(y)) + y = y1 + IE_NEWFRAME(ie) = wcs + if (IE_DFRAME(ie) <= 0) + IE_DFRAME(ie) = IE_NEWFRAME(ie) + + case 'g': + nitems = clgcur ("graphcur", x, y, wcs, k[i], strval, maxch) + + # Make any needed default coordinate conversions from the + # graphic coordinates. + + switch (IE_GTYPE(ie)) { + case 'c', 'k': # Column plot + y = x + x = IE_X1(ie) + + if (IS_INDEF(y)) + y = y1 + else if (IE_MW(ie) != NULL) { + if (streq (IE_WCSNAME(ie), "logical")) + ; + else if (streq (IE_WCSNAME(ie), "physical")) + call ie_imwctran (ie, x, y, dx, y) + else { + r = y + y = IM_LEN(IE_IM(ie),2) + call ie_mwctran (ie, x, 1., dx, y1) + call ie_mwctran (ie, x, y, dx, y2) + dy = y + while (dy > .001) { + dy = dy / 2 + if (r > y1) { + if (r < y2) + y = y - dy + else + y = y + dy + } else { + if (r < y2) + y = y + dy + else + y = y - dy + } + call ie_mwctran (ie, x, y, dx, y2) + } + } + } + case 'e': # Contour plot + if (IS_INDEF(x)) + x = x1 + if (IS_INDEF(y)) + y = y1 + case 'j', 'l': # Line plot + y = IE_Y1(ie) + + if (IS_INDEF(x)) + x = x1 + else if (IE_MW(ie) != NULL) { + if (streq (IE_WCSNAME(ie), "logical")) + ; + else if (streq (IE_WCSNAME(ie), "physical")) + call ie_imwctran (ie, x, y, x, dy) + else { + r = x + x = IM_LEN(IE_IM(ie),1) + call ie_mwctran (ie, 1., y, x1, dy) + call ie_mwctran (ie, x, y, x2, dy) + dx = x + while (dx > .001) { + dx = dx / 2 + if (r > x1) { + if (r < x2) + x = x - dx + else + x = x + dx + } else { + if (r < x2) + x = x + dx + else + x = x - dx + } + call ie_mwctran (ie, x, y, x2, dy) + } + } + } + case 'r','.': # Radial profile plot + x = IE_X1(ie) + y = IE_Y1(ie) + case 'h', 's': # Surface plot + x = IE_X1(ie) + y = IE_Y1(ie) + case 'u': # Vector plot + if (IS_INDEF(x)) + x = x1 + y = x * sina + (IE_Y1(ie) + IE_Y2(ie)) / 2 + x = x * cosa + (IE_X1(ie) + IE_X2(ie)) / 2 + case 'v': # Vector plot + if (IS_INDEF(x)) + x = x1 + y = x * sina + IE_Y1(ie) + x = x * cosa + IE_X1(ie) + } + } + + key = k[1] + switch (key) { + case 'v', 'u': + if (i == 1) { + x1 = x + y1 = y + call printf ("again:") + } else { + x2 = x + y2 = y + r = sqrt (real ((y2-y1)**2 + (x2-x1)**2)) + if (r > 0.) { + cosa = (x2 - x1) / r + sina = (y2 - y1) / r + } else { + cosa = 0. + sina = 0. + } + call printf ("\n") + switch (key) { + case 'v': + x = x1 + y = y1 + case 'u': + x = 2 * x1 - x2 + y = 2 * y1 - y2 + } + IE_X2(ie) = x2 + IE_Y2(ie) = y2 + break + } + case 'b': + if (i == 1) { + IE_IX1(ie) = x + 0.5 + IE_IY1(ie) = y + 0.5 + call printf ("again:") + } else { + IE_IX2(ie) = x + 0.5 + IE_IY2(ie) = y + 0.5 + call printf ("\n") + temp = IE_IX1(ie) + IE_IX1(ie) = min (IE_IX1(ie), IE_IX2(ie)) + IE_IX2(ie) = max (temp, IE_IX2(ie)) + temp = IE_IY1(ie) + IE_IY1(ie) = min (IE_IY1(ie), IE_IY2(ie)) + IE_IY2(ie) = max (temp, IE_IY2(ie)) + break + } + default: + break + } + } + + # Map numeric colon sequences (: x [y] key strval) to make them appear + # as ordinary "x y key" type cursor reads. This makes it possible for + # the user to access any command using typed in rather than positional + # cursor coordinates. Special treatment is also given to the syntax + # ":lN" and ":cN", provided for compatibility with IMPLOT for simple + # line and column plots. + + if (key == ':') { + for (ip=1; IS_WHITE(strval[ip]); ip=ip+1) + ; + if (IS_DIGIT(strval[ip])) { + if (ctor (strval, ip, x) <= 0) + ; + if (ctor (strval, ip, y) <= 0) + y = x + for (; IS_WHITE(strval[ip]); ip=ip+1) + ; + if (cctoc (strval, ip, ch) > 0) + key = ch + call strcpy (strval[ip], strval, maxch) + + } else if (strval[ip] == 'l' && IS_DIGIT(strval[ip+1])) { + ip = ip + 1 + if (ctor (strval, ip, x) > 0) { + y = x + key = 'l' + } + } else if (strval[ip] == 'c' && IS_DIGIT(strval[ip+1])) { + ip = ip + 1 + if (ctor (strval, ip, x) > 0) { + y = x + key = 'c' + } + } + } + + return (nitems) +end diff --git a/pkg/images/tv/imexamine/iegdata.x b/pkg/images/tv/imexamine/iegdata.x new file mode 100644 index 00000000..6e1f7e91 --- /dev/null +++ b/pkg/images/tv/imexamine/iegdata.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IE_GDATA -- Get image data with boundary checking. + +pointer procedure ie_gdata (im, x1, x2, y1, y2) + +pointer im # IMIO pointer +int x1, x2, y1, y2 # Subraster limits (input and output) + +int i, 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) + call error (1, "Pixels out of bounds") + + x1 = max (1, x1) + x2 = min (nc, x2) + y1 = max (1, y1) + y2 = min (nl, y2) + + return (imgs2r (im, x1, x2, y1, y2)) +end diff --git a/pkg/images/tv/imexamine/iegimage.x b/pkg/images/tv/imexamine/iegimage.x new file mode 100644 index 00000000..b0fda919 --- /dev/null +++ b/pkg/images/tv/imexamine/iegimage.x @@ -0,0 +1,261 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + +# IE_GIMAGE -- Get input image name and return IMIO pointer. +# If examining a list of images access the indexed image, displaying it if +# not already displayed. Otherwise the image loaded into the current display +# frame is displayed, if it can be accessed, or the image frame buffer itself +# is examined. If there is neither a list of images nor display access the +# user is queried for the name of the image to be examined. +# This procedure uses a prototype display interface (IMD/IW). + +pointer procedure ie_gimage (ie, select) + +pointer ie #I IMEXAM pointer +int select #I select frame? + +char errstr[SZ_FNAME] +int frame, i, j, k +pointer sp, image, dimage, imname, im + +int imtrgetim(), fnldir(), errget() +bool strne(), streq() +pointer imd_mapframe(), immap() +errchk imd_mapframe, immap, ie_display, ie_mwinit + + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (dimage, SZ_FNAME, TY_CHAR) + + # Get image name, and display image if using display. If we are + # examining a list of images, the list and the current index into + # the list determine the image to be examined. If there is no list + # we examine the currently displayed images, if any, else the + # contents of the image display frame buffers are examined as images. + + if (IE_LIST(ie) != NULL) { + # Get image name. + IE_INDEX(ie) = max(1, min(IE_LISTLEN(ie), IE_INDEX(ie))) + if (imtrgetim (IE_LIST(ie), IE_INDEX(ie), Memc[image], + SZ_FNAME) == EOF) + call error (1, "Reference outside of image list") + + # Display image. + if (IE_USEDISPLAY(ie) == YES) { + # Is named image currently loaded into the image display? + frame = 0 + if (streq (Memc[image], IE_IMAGE(ie))) + frame = IE_MAPFRAME(ie) + else { + if (IE_DS(ie) == NULL) + IE_DS(ie) = imd_mapframe (max (1, IE_NEWFRAME(ie)/100), + READ_WRITE, NO) + + do i = 1, IE_NFRAMES(ie) { + if (i == IE_MAPFRAME(ie)/100) + next + do j = 1, 99 { + k = i * 100 + j + iferr (call ie_imname (IE_DS(ie), k, + Memc[dimage], SZ_FNAME)) + break + if (streq (Memc[image], Memc[dimage])) { + frame = k + break + } + } + if (frame != 0) + break + } + } + + # Load image into display frame if not already loaded. + # If the allframes option is specified cycle through the + # available display frames, otherwise resuse the same frame. + + if (frame == 0) { + if (IE_DS(ie) != NULL) { + if (IE_IM(ie) == IE_DS(ie)) + IE_IM(ie) = NULL + call imunmap (IE_DS(ie)) + } + + frame = 100 * max (1, IE_DFRAME(ie) / 100) + 1 + call ie_display (ie, Memc[image], frame/100) + + IE_MAPFRAME(ie) = 0 + if (IE_ALLFRAMES(ie) == YES) { + IE_DFRAME(ie) = frame + 100 + if (IE_DFRAME(ie)/100 > IE_NFRAMES(ie)) + IE_DFRAME(ie) = 101 + } + } + + # Map and display-select the frame. + if (frame != IE_MAPFRAME(ie) || frame != IE_NEWFRAME(ie)) { + if (IE_DS(ie) != NULL) { + if (IE_IM(ie) == IE_DS(ie)) + IE_IM(ie) = NULL + call imunmap (IE_DS(ie)) + } + IE_DS(ie) = imd_mapframe (frame/100, READ_WRITE, select) + IE_MAPFRAME(ie) = frame + IE_NEWFRAME(ie) = frame + } + } + + } else if (IE_USEDISPLAY(ie) == YES) { + # Map the new display frame. + if (IE_NEWFRAME(ie) != IE_MAPFRAME(ie)) { + if (IE_NEWFRAME(ie)/100 != IE_MAPFRAME(ie)/100) { + if (IE_DS(ie) != NULL) { + if (IE_IM(ie) == IE_DS(ie)) + IE_IM(ie) = NULL + call imunmap (IE_DS(ie)) + } + IE_DS(ie) = imd_mapframe (IE_NEWFRAME(ie)/100, READ_WRITE, + select) + } + IE_MAPFRAME(ie) = IE_NEWFRAME(ie) + } + + # Get the image name. + call ie_imname (IE_DS(ie), IE_MAPFRAME(ie), Memc[image], SZ_FNAME) + + } else + call clgstr ("image", Memc[image], SZ_FNAME) + + # Check if the image has not been mapped and if so map it. + # Possibly log any change of image. Always map the physical image, + # not a section, since we do everything in image coordinates. + + if (IE_IM(ie) == NULL || strne (Memc[image], IE_IMAGE(ie))) { + + # Strip the path. + call imgcluster (Memc[image], Memc[imname], SZ_FNAME) + i = fnldir (Memc[imname], Memc[imname], SZ_FNAME) + call strcpy (Memc[image+i], IE_IMNAME(ie), IE_SZFNAME) + + # Map the image. + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + # Warn user once. + i = errget (Memc[imname], SZ_FNAME) + if (strne (Memc[imname], errstr)) { + call erract (EA_WARN) + call strcpy (Memc[imname], errstr, SZ_FNAME) + } + + # Access the display frame buffer as the data image. + if (IE_USEDISPLAY(ie) == YES && IE_LIST(ie) == NULL) { + if (IE_IM(ie) != NULL && IE_IM(ie) != IE_DS(ie)) + iferr (call imunmap (IE_IM(ie))) + ; + IE_IM(ie) = IE_DS(ie) + call sprintf (IE_IMAGE(ie), IE_SZFNAME, "Frame.%d(%s)") + call pargi (IE_MAPFRAME(ie)) + call pargstr (IE_IMNAME(ie)) + call strcpy ("Contents of raw image frame buffer\n", + IM_TITLE(IE_IM(ie)), SZ_IMTITLE) + } else + call erract (EA_WARN) + + } else { + # Adjust image sections. + call ie_gimage1 (im, Memc[image], Memc[imname], SZ_FNAME) + if (strne (Memc[image], Memc[imname])) { + call imunmap (im) + im = immap (Memc[imname], READ_ONLY, 0) + } + + # Make the new image the current one. + errstr[1] = EOS + call strcpy (Memc[image], IE_IMAGE(ie), IE_SZFNAME) + if (IE_IM(ie) != NULL && IE_IM(ie) != IE_DS(ie)) + iferr (call imunmap (IE_IM(ie))) + ; + if (IE_MW(ie) != NULL) + call mw_close (IE_MW(ie)) + IE_IM(ie) = im + if (IE_LOGFD(ie) != NULL) { + call fprintf (IE_LOGFD(ie), "# [%d] %s - %s\n") + call pargi (IE_INDEX(ie)) + call pargstr (IE_IMNAME(ie)) + call pargstr (IM_TITLE(IE_IM(ie))) + } + } + } + + call ie_mwinit (ie) + + call sfree (sp) + return (IE_IM(ie)) +end + + +# IE_GIMAGE1 -- Convert input image section name to a 2D physical image section. + +procedure ie_gimage1 (im, input, output, maxchar) + +pointer im #I IMIO pointer +char input[ARB] #I Input image name +char output[maxchar] #O Output image name +int maxchar #I Maximum characters in output name. + +int i, fd +pointer sp, section, lv, pv1, pv2 + +int stropen(), strlen() +bool streq() + +begin + call smark (sp) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (lv, IM_MAXDIM, TY_LONG) + call salloc (pv1, IM_MAXDIM, TY_LONG) + call salloc (pv2, IM_MAXDIM, TY_LONG) + + # Get endpoint coordinates in original image. + call amovkl (long(1), Meml[lv], IM_MAXDIM) + call aclrl (Meml[pv1], IM_MAXDIM) + call imaplv (im, Meml[lv], Meml[pv1], 2) + call amovl (IM_LEN(im,1), Meml[lv], IM_NDIM(im)) + call aclrl (Meml[pv2], IM_MAXDIM) + call imaplv (im, Meml[lv], Meml[pv2], 2) + + # Set image section. + fd = stropen (Memc[section], SZ_FNAME, NEW_FILE) + call fprintf (fd, "[") + do i = 1, IM_MAXDIM { + if (Meml[pv1+i-1] != Meml[pv2+i-1]) + call fprintf (fd, "*") + else if (Meml[pv1+i-1] != 0) { + call fprintf (fd, "%d") + call pargi (Meml[pv1+i-1]) + } else + break + call fprintf (fd, ",") + } + call close (fd) + i = strlen (Memc[section]) + Memc[section+i-1] = ']' + + if (streq ("[*,*]", Memc[section])) + Memc[section] = EOS + + # Strip existing image section and add new section. + call imgimage (input, output, maxchar) + call strcat (Memc[section], output, maxchar) + +# if (Memc[section] == EOS) +# call imgimage (input, output, maxchar) +# else +# call strcpy (input, output, maxchar) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iegnfr.x b/pkg/images/tv/imexamine/iegnfr.x new file mode 100644 index 00000000..0a8fb30d --- /dev/null +++ b/pkg/images/tv/imexamine/iegnfr.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imexam.h" + +# IE_GETNFRAMES -- Determine the number of image display frames. If the +# display can be accessed at all we assume there is always at least one +# frame; beyond that presence of a valid WCS is used to test whether we +# are interested in looking at a frame. + +int procedure ie_getnframes (ie) + +pointer ie #I imexamine descriptor + +pointer sp, imname, ds, iw +int server, nframes, status, i + +int clgeti(), strncmp(), imd_wcsver() +pointer imd_mapframe(), iw_open() +errchk imd_mapframe, clgeti + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + + nframes = clgeti ("nframes") + if (nframes == 0) { + # Try to automatically determine the number of frames. + ds = IE_DS(ie) + if (ds == NULL) + ds = imd_mapframe (1, READ_WRITE, NO) + + # If we are talking to a simple image display we assume the device + # has 4 frames (until more general display interfaces come along). + # Servers are more complicated because the number of frames is + # dynamically configurable, even while imexamine is running. + # We use the WCS query to try to count the current number of + # allocated frames in the case of a server device. + + server = IM_LEN(ds,4) + if (server == YES && imd_wcsver() != 0) { + nframes = 1 + do i = 1, MAX_FRAMES { + iferr (iw = iw_open (ds, i, Memc[imname], SZ_FNAME, status)) + next + call iw_close (iw) + if (strncmp (Memc[imname], "[NOSUCHFRAME]", 3) != 0) + nframes = max (nframes, i) + } + } else + nframes = 4 + + if (IE_DS(ie) == NULL) + call imunmap (ds) + } + + IE_NFRAMES(ie) = max (nframes, IE_DFRAME(ie)/100) + call sfree (sp) + + return (nframes) +end diff --git a/pkg/images/tv/imexamine/iegraph.x b/pkg/images/tv/imexamine/iegraph.x new file mode 100644 index 00000000..edfa28c2 --- /dev/null +++ b/pkg/images/tv/imexamine/iegraph.x @@ -0,0 +1,145 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imexam.h" + +define MTYPES "|point|box|plus|cross|circle|hebar|vebar|hline|vline|diamond|" +define IE_GBUF 0.10 # Buffer around data +define IE_SZTITLE 512 # Size of multiline title + + +# IE_GRAPH -- Make a graph +# This procedure is used by most of the different graph types to provide +# consistency in features and parameters. The parameters are read using +# the pset pointer. + +procedure ie_graph (gp, mode, pp, param, x, y, npts, label, format) + +pointer gp # GIO pointer +int mode # Mode +pointer pp # PSET pointer +char param[ARB] # Parameter string +real x[npts] # X data +real y[npts] # Y data +int npts # Number of points +char label # Default x label +char format # Default x format + +int i, marks[10], linepattern, patterns[4], clgpseti(), btoi(), strdic() +pointer sp, title, xlabel, ylabel +real x1, x2, y1, y2, wx1, wx2, wy1, wy2, temp, szmarker +real clgpsetr(), ie_iformatr() +bool clgpsetb(), streq() + +data patterns/GL_SOLID, GL_DASHED, GL_DOTTED, GL_DOTDASH/ +data marks/GM_POINT, GM_BOX, GM_PLUS, GM_CROSS, GM_CIRCLE, GM_HEBAR, + GM_VEBAR, GM_HLINE, GM_VLINE, GM_DIAMOND/ + +begin + call smark (sp) + call salloc (xlabel, SZ_LINE, TY_CHAR) + + # If a new graph setup all the axes and labeling options and then + # make the graph. + + if (mode == NEW_FILE) { + call gclear (gp) + + linepattern = 0 + + x1 = ie_iformatr (clgpsetr (pp, "x1"), format) + x2 = ie_iformatr (clgpsetr (pp, "x2"), format) + y1 = clgpsetr (pp, "y1") + y2 = clgpsetr (pp, "y2") + + if (IS_INDEF (x1) || IS_INDEF (x2)) + call gascale (gp, x, npts, 1) + if (IS_INDEF (y1) || IS_INDEF (y2)) + call gascale (gp, y, npts, 2) + + call gswind (gp, x1, x2, y1, y2) + call ggwind (gp, wx1, wx2, wy1, wy2) + + temp = wx2 - wx1 + if (IS_INDEF (x1)) + wx1 = wx1 - IE_GBUF * temp + if (IS_INDEF (x2)) + wx2 = wx2 + IE_GBUF * temp + + temp = wy2 - wy1 + if (IS_INDEF (y1)) + wy1 = wy1 - IE_GBUF * temp + if (IS_INDEF (y2)) + wy2 = wy2 + IE_GBUF * temp + + call gswind (gp, wx1, wx2, wy1, wy2) + call gsetr (gp, G_ASPECT, 0.) + call gseti (gp, G_ROUND, btoi (clgpsetb (pp, "round"))) + + i = GW_LINEAR + if (clgpsetb (pp, "logx")) + i = GW_LOG + call gseti (gp, G_XTRAN, i) + i = GW_LINEAR + if (clgpsetb (pp, "logy")) + i = GW_LOG + call gseti (gp, G_YTRAN, i) + + if (clgpsetb (pp, "box")) { + # Get number of major and minor tick marks. + call gseti (gp, G_XNMAJOR, clgpseti (pp, "majrx")) + call gseti (gp, G_XNMINOR, clgpseti (pp, "minrx")) + call gseti (gp, G_YNMAJOR, clgpseti (pp, "majry")) + call gseti (gp, G_YNMINOR, clgpseti (pp, "minry")) + + # Label tick marks on axes? + call gsets (gp, G_XTICKFORMAT, format) + call gseti (gp, G_LABELTICKS, + btoi (clgpsetb (pp, "ticklabels"))) + + # Fetch labels and plot title string. + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (ylabel, SZ_LINE, TY_CHAR) + + if (clgpsetb (pp, "banner")) { + call sysid (Memc[title], IE_SZTITLE) + call strcat ("\n", Memc[title], IE_SZTITLE) + call strcat (param, Memc[title], IE_SZTITLE) + } else + Memc[title] = EOS + + call clgpset (pp, "title", Memc[xlabel], SZ_LINE) + if (Memc[xlabel] != EOS) { + call strcat ("\n", Memc[title], IE_SZTITLE) + call strcat (Memc[xlabel], Memc[title], IE_SZTITLE) + } + call clgpset (pp, "xlabel", Memc[xlabel], SZ_LINE) + call clgpset (pp, "ylabel", Memc[ylabel], SZ_LINE) + + if (streq ("wcslabel", Memc[xlabel])) + call strcpy (label, Memc[xlabel], SZ_LINE) + + call glabax (gp, Memc[title], Memc[xlabel], Memc[ylabel]) + } + } + + # Draw the data. + if (clgpsetb (pp, "pointmode")) { + call clgpset (pp, "marker", Memc[xlabel], SZ_LINE) + i = strdic (Memc[xlabel], Memc[xlabel], SZ_LINE, MTYPES) + if (i == 0) + i = 2 + if (marks[i] == GM_POINT) + szmarker = 0.0 + else + szmarker = clgpsetr (pp, "szmarker") + call gpmark (gp, x, y, npts, marks[i], szmarker, szmarker) + } else { + linepattern = min (4, linepattern + 1) + call gseti (gp, G_PLTYPE, patterns[linepattern]) + call gpline (gp, x, y, npts) + } + call gflush (gp) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iehimexam.x b/pkg/images/tv/imexamine/iehimexam.x new file mode 100644 index 00000000..4a0fd150 --- /dev/null +++ b/pkg/images/tv/imexamine/iehimexam.x @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + +define HGM_TYPES "|line|box|" +define HGM_LINE 1 # line vectors for histogram plot +define HGM_BOX 2 # box vectors for histogram plot + +# IE_HIMEXAM -- Compute and plot or list a histogram. +# If the GIO pointer is NULL list the histogram otherwise make a graph. + +procedure ie_himexam (gp, mode, ie, x, y) + +pointer gp # GIO pointer (NULL for histogram listing) +int mode # Mode +pointer ie # Structure pointer +real x, y # Center coordinate + +real z1, z2, dz, zmin, zmax +int i, j, x1, x2, y1, y2, nx, ny, npts, nbins, nbins1, nlevels, nwide +pointer pp, sp, hgm, title, im, data, xp, yp + +int clgpseti() +real clgpsetr() +bool clgpsetb(), fp_equalr() +pointer clopset(), ie_gimage(), ie_gdata() + +begin + # Get the image and return on error. + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + # Use last graph coordinate if redrawing. Close last graph pset + # pointer if making new graph. + + if (gp != NULL) { + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + z1 = IE_X1(ie) + z2 = IE_Y1(ie) + + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + } else { + z1 = x + z2 = y + } + + # Get the data. + pp = clopset ("himexam") + nx = clgpseti (pp, "ncolumns") + ny = clgpseti (pp, "nlines") + x1 = z1 - (nx - 1) / 2 + 0.5 + x2 = z1 + nx / 2 + 0.5 + y1 = z2 - (ny - 1) / 2 + 0.5 + y2 = z2 + ny / 2 + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + # Get default histogram resolution. + nbins = clgpseti (pp, "nbins") + + # Get histogram range. + z1 = clgpsetr (pp, "z1") + z2 = clgpsetr (pp, "z2") + + # Use data limits for INDEF limits. + if (IS_INDEFR(z1) || IS_INDEFR(z2)) { + call alimr (Memr[data], npts, zmin, zmax) + if (IS_INDEFR(z1)) + z1 = zmin + if (IS_INDEFR(z2)) + z2 = zmax + } + + if (z1 > z2) { + dz = z1; z1 = z2; z2 = dz + } + + # Adjust the resolution of the histogram and/or the data range + # so that an integral number of data values map into each + # histogram bin (to avoid aliasing effects). + + if (clgpsetb (pp, "autoscale")) { + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + nlevels = nint (z2) - nint (z1) + nwide = max (1, nint (real (nlevels) / real (nbins))) + nbins = max (1, nint (real (nlevels) / real (nwide))) + z2 = nint (z1) + nbins * nwide + } + } + + # Test for constant valued image, which causes zero divide in ahgm. + if (fp_equalr (z1, z2)) { + call eprintf ("Warning: Image `%s' has no data range.\n") + call pargstr (IE_IMAGE(ie)) + return + } + + # The extra bin counts the pixels that equal z2 and shifts the + # remaining bins to evenly cover the interval [z1,z2]. + # Note that real numbers could be handled better - perhaps + # adjust z2 upward by ~ EPSILONR (in ahgm itself). + + nbins1 = nbins + 1 + + # Initialize the histogram buffer and image line vector. + call smark (sp) + call salloc (hgm, nbins1, TY_INT) + call aclri (Memi[hgm], nbins1) + + call ahgmr (Memr[data], npts, Memi[hgm], nbins1, z1, z2) + + # "Correct" the topmost bin for pixels that equal z2. Each + # histogram bin really wants to be half open. + + if (clgpsetb (pp, "top_closed")) + Memi[hgm+nbins-1] = Memi[hgm+nbins-1] + Memi[hgm+nbins1-1] + + # List or plot the histogram. In list format, the bin value is the + # z value of the left side (start) of the bin. + + dz = (z2 - z1) / real (nbins) + + if (gp != NULL) { + # Draw the plot. + if (clgpsetb (pp, "pointmode")) { + nbins1 = nbins + call salloc (xp, nbins1, TY_REAL) + call salloc (yp, nbins1, TY_REAL) + call achtir (Memi[hgm], Memr[yp], nbins1) + Memr[xp] = z1 + dz / 2. + do i = 1, nbins1 - 1 + Memr[xp+i] = Memr[xp+i-1] + dz + } else { + nbins1 = 2 * nbins + call salloc (xp, nbins1, TY_REAL) + call salloc (yp, nbins1, TY_REAL) + Memr[xp] = z1 + Memr[yp] = Memi[hgm] + j = 0 + do i = 1, nbins - 1 { + Memr[xp+j+1] = Memr[xp+j] + dz + Memr[yp+j+1] = Memr[yp+j] + j = j + 1 + Memr[xp+j+1] = Memr[xp+j] + Memr[yp+j+1] = Memi[hgm+i] + j = j + 1 + } + Memr[xp+j+1] = Memr[xp+j] + dz + Memr[yp+j+1] = Memr[yp+j] + } + + call salloc (title, IE_SZTITLE, TY_CHAR) + call sprintf (Memc[title], IE_SZTITLE, + "%s[%d:%d,%d:%d]: Histogram from z1=%g to z2=%g, nbins=%d\n%s") + call pargstr (IE_IMNAME(ie)) + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + call pargr (z1) + call pargr (z2) + call pargi (nbins) + call pargstr (IM_TITLE(im)) + call ie_graph (gp, mode, pp, Memc[title], Memr[xp], + Memr[yp], nbins1, "", "") + + IE_PP(ie) = pp + } else { + do i = 1, nbins { + call printf ("%g %d\n") + call pargr (z1 + (i-1) * dz) + call pargi (Memi[hgm+i-1]) + } + call clcpset (pp) + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ieimname.x b/pkg/images/tv/imexamine/ieimname.x new file mode 100644 index 00000000..3b1bd5e9 --- /dev/null +++ b/pkg/images/tv/imexamine/ieimname.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IE_IMNAME -- Get the name of the image displayed in a display frame. + +procedure ie_imname (ds, frame, imname, maxch) + +pointer ds #I display descriptor +int frame #I display frame +char imname[maxch] #O image name +int maxch #I max chars out + +int snx, sny, dx, dy, dnx, dny, status, imd_query_map() +real sx, sy +pointer sp, reg, dname, iw +pointer iw_open() +errchk imd_query_map, iw_open + +begin + call smark (sp) + call salloc (reg, SZ_FNAME, TY_CHAR) + call salloc (dname, SZ_FNAME, TY_CHAR) + + if (imd_query_map (frame, Memc[reg], sx, sy, snx, sny, dx, dy, dnx, dny, + Memc[dname]) == ERR) { + iw = iw_open (ds, frame/100, Memc[dname], SZ_FNAME, status) + call iw_close (iw) + } + + # call imgimage (Memc[dname], imname, maxch) + call strcpy (Memc[dname], imname, maxch) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iejimexam.x b/pkg/images/tv/imexamine/iejimexam.x new file mode 100644 index 00000000..46a4c910 --- /dev/null +++ b/pkg/images/tv/imexamine/iejimexam.x @@ -0,0 +1,473 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "imexam.h" + + +# IE_JIMEXAM -- 1D profile plot and gaussian fit parameters. +# If no GIO pointer is given then only the fit parameters are printed. +# The fitting uses a Levenberg-Marquardt nonlinear chi square minimization. + +procedure ie_jimexam (gp, mode, ie, x, y, axis) + +pointer gp +pointer ie +int mode +real x, y +int axis + +int navg, order, clgpseti() +bool center, background, clgpsetb() +real sigma, width, rplot, clgpsetr() + +int i, j, k, nx, ny, x1, x2, y1, y2, nfit, flag[5] +real xc, yc, bkg, r, dr, fit[5], xfit, yfit, asumr(), amedr() +pointer sp, title, avstr, im, pp, data, xs, ys, ptr +pointer clopset(), ie_gimage(), ie_gdata() + +errchk ie_gdata, mr_solve + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + # Get parameters + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + if (axis == 1) + IE_PP(ie) = clopset ("jimexam") + else + IE_PP(ie) = clopset ("kimexam") + pp = IE_PP(ie) + navg = clgpseti (pp, "naverage") + center = clgpsetb (pp, "center") + background = clgpsetb (pp, "background") + sigma = clgpsetr (pp, "sigma") + rplot = clgpsetr (pp, "rplot") + if (background) { + order = clgpsetr (pp, "xorder") + width = clgpsetr (pp, "width") + } + + # If the initial center is INDEF then use the previous value. + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + if (axis == 1) { + xc = IE_X1(ie) + yc = IE_Y1(ie) + } else { + xc = IE_Y1(ie) + yc = IE_X1(ie) + } + + # Get data + r = max (rplot, 8 * sigma + width) + x1 = xc - r + x2 = xc + r + y1 = nint (yc) - (navg - 1) / 2 + y2 = nint (yc) + navg / 2 + iferr { + if (axis == 1) + data = ie_gdata (im, x1, x2, y1, y2) + else + data = ie_gdata (im, y1, y2, x1, x2) + } then { + call erract (EA_WARN) + return + } + + # Compute average vector + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + yc = (y1 + y2) / 2. + + call smark (sp) + call salloc (xs, nx, TY_REAL) + call salloc (ys, nx, TY_REAL) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (avstr, SZ_LINE, TY_CHAR) + + ptr = data + if (axis == 1) { + call sprintf (Memc[avstr], SZ_LINE, "Lines %d-%d") + call pargi (y1) + call pargi (y2) + call amovr (Memr[ptr], Memr[ys], nx) + ptr = ptr + nx + do i = 2, ny { + call aaddr (Memr[ptr], Memr[ys], Memr[ys], nx) + ptr = ptr + nx + } + call adivkr (Memr[ys], real (ny), Memr[ys], nx) + } else { + call sprintf (Memc[avstr], SZ_LINE, "Columns %d-%d") + call pargi (y1) + call pargi (y2) + do i = 0, nx-1 { + Memr[ys+i] = asumr (Memr[ptr], ny) / ny + ptr = ptr + ny + } + } + + # Set default background + bkg = 0. + if (background) { + r = 4 * sigma + ptr = xs + do i = 0, nx-1 { + if (abs (xc - x1 - i) > r) { + Memr[ptr] = Memr[ys+i] + ptr = ptr + 1 + } + } + if (ptr > xs) + bkg = amedr (Memr[xs], ptr-xs) + } + + # Convert to WCS + if (axis == 1) { + call ie_mwctran (ie, xc, yc, xfit, yfit) + call ie_mwctran (ie, xc+sigma, yc, r, yfit) + dr = abs (xfit - r) + do i = 0, nx-1 + call ie_mwctran (ie, real(x1+i), yc, Memr[xs+i], yfit) + } else { + call ie_mwctran (ie, yc, xc, yfit, xfit) + call ie_mwctran (ie, yc, xc+sigma, yfit, r) + dr = abs (xfit - r) + do i = 0, nx-1 + call ie_mwctran (ie, yc, real(x1+i), yfit, Memr[xs+i]) + } + + # Set initial fit parameters + k = max (0, nint (xc - x1)) + fit[1] = bkg + fit[2] = 0. + fit[3] = Memr[ys+k] - fit[1] + fit[4] = xfit + fit[5] = dr + + # Do fitting. + nfit = 1 + flag[1] = 3 + + # Add centering if desired + if (center) { + nfit = nfit + 1 + flag[nfit] = 4 + call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) + } + + # Add sigma + nfit = nfit + 1 + flag[nfit] = 5 + call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) + + # Now add background if desired + if (background) { + if (order == 1) { + nfit = nfit + 1 + flag[nfit] = 1 + call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) + } else if (order == 2) { + nfit = nfit + 2 + flag[nfit-1] = 1 + flag[nfit] = 2 + call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) + } + } + + # Plot the profile and overplot the gaussian fit. + call sprintf (Memc[title], IE_SZTITLE, "%s: %s\n%s") + call pargstr (IE_IMNAME(ie)) + call pargstr (Memc[avstr]) + call pargstr (IM_TITLE(im)) + + j = max (0, int (xc - x1 - rplot)) + k = min (nx-1, nint (xc - x1 + rplot)) + if (axis == 1) + call ie_graph (gp, mode, pp, Memc[title], + Memr[xs+j], Memr[ys+j], k-j+1, IE_XLABEL(ie), IE_XFORMAT(ie)) + else + call ie_graph (gp, mode, pp, Memc[title], + Memr[xs+j], Memr[ys+j], k-j+1, IE_YLABEL(ie), IE_YFORMAT(ie)) + + call gseti (gp, G_PLTYPE, 2) + xfit = min (Memr[xs+j], Memr[xs+k]) + r = (xfit - fit[4]) / fit[5] + dr = abs ((Memr[xs+k] - Memr[xs+j]) / (k - j)) + if (abs (r) < 7.) + yfit = fit[1] + fit[2] * xfit + fit[3] * exp (-r**2 / 2.) + else + yfit = fit[1] + fit[2] * xfit + call gamove (gp, xfit, yfit) + repeat { + xfit = xfit + 0.2 * dr + r = (xfit - fit[4]) / fit[5] + if (abs (r) < 7.) + yfit = fit[1] + fit[2] * xfit + fit[3] * exp (-r**2 / 2.) + else + yfit = fit[1] + fit[2] * xfit + call gadraw (gp, xfit, yfit) + } until (xfit >= max (Memr[xs+j], Memr[xs+k])) + call gseti (gp, G_PLTYPE, 1) + + # Print the fit values + call printf ("%s: center=%7g peak=%7g sigma=%7.4g fwhm=%7.4g bkg=%7g\n") + call pargstr (Memc[avstr]) + call pargr (fit[4]) + call pargr (fit[3]) + call pargr (fit[5]) + call pargr (2.35482*fit[5]) + call pargr (fit[1]+fit[2]*fit[4]) + + if (IE_LOGFD(ie) != NULL) { + call fprintf (IE_LOGFD(ie), + "%s: center=%7g peak=%7g sigma=%5.3f fwhm=%5.3f bkg=%7g\n") + call pargstr (Memc[avstr]) + call pargr (fit[4]) + call pargr (fit[3]) + call pargr (fit[5]) + call pargr (2.35482*fit[5]) + call pargr (fit[1]+fit[2]*fit[4]) + } + + call sfree (sp) +end + + +# IE_GFIT -- 1D Gaussian fit. + +procedure ie_gfit (xs, ys, nx, fit, flag, nfit) + +real xs[nx], ys[nx] # Vector to be fit +int nx # Number of points +real fit[5] # Fit parameters +int flag[nfit] # Flag for parameters to be fit +int nfit # Number of parameters to be fit + +int i +real chi1, chi2, mr + +begin + chi2 = MAX_REAL + mr = -1. + i = 0 + repeat { + call mr_solve (xs, ys, nx, fit, flag, 5, nfit, mr, chi1) + if (chi2 - chi1 > 1.) + i = 0 + else + i = i + 1 + chi2 = chi1 + } until (i == 3) + mr = 0. + call mr_solve (xs, ys, nx, fit, flag, 5, nfit, mr, chi1) + + fit[5] = abs (fit[5]) +end + + +# DERIVS -- Compute model and derivatives for MR_SOLVE procedure. +# +# I(x) = A1 + A2 * x + A3 exp {-[(x - A4) / A5]**2 / 2.} +# +# where the params are A1-A5. + +procedure derivs (x, a, y, dyda, na) + +real x # X value to be evaluated +real a[na] # Parameters +real y # Function value +real dyda[na] # Derivatives +int na # Number of parameters + +real arg, ex, fac + +begin + arg = (x - a[4]) / a[5] + if (abs (arg) < 7.) + ex = exp (-arg**2 / 2.) + else + ex = 0. + fac = a[3] * ex * arg + + y = a[1] + a[2] * x + a[3] * ex + + dyda[1] = 1. + dyda[2] = x + dyda[3] = ex + dyda[4] = fac / a[5] + dyda[5] = fac * arg / a[5] +end + + +# MR_SOLVE -- Levenberg-Marquardt nonlinear chi square minimization. +# +# Use the Levenberg-Marquardt method to minimize the chi squared of a set +# of paraemters. The parameters being fit are indexed by the flag array. +# To initialize the Marquardt parameter, MR, is less than zero. After that +# the parameter is adjusted as needed. To finish set the parameter to zero +# to free memory. This procedure requires a subroutine, DERIVS, which +# takes the derivatives of the function being fit with respect to the +# parameters. There is no limitation on the number of parameters or +# data points. For a description of the method see NUMERICAL RECIPES +# by Press, Flannery, Teukolsky, and Vetterling, p523. + +procedure mr_solve (x, y, npts, params, flags, np, nfit, mr, chisq) + +real x[npts] # X data array +real y[npts] # Y data array +int npts # Number of data points +real params[np] # Parameter array +int flags[np] # Flag array indexing parameters to fit +int np # Number of parameters +int nfit # Number of parameters to fit +real mr # MR parameter +real chisq # Chi square of fit + +int i +real chisq1 +pointer new, a1, a2, delta1, delta2 + +errchk mr_invert + +begin + # Allocate memory and initialize. + if (mr < 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + + call malloc (new, np, TY_REAL) + call malloc (a1, nfit*nfit, TY_REAL) + call malloc (a2, nfit*nfit, TY_REAL) + call malloc (delta1, nfit, TY_REAL) + call malloc (delta2, nfit, TY_REAL) + + call amovr (params, Memr[new], np) + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a2], + Memr[delta2], nfit, chisq) + mr = 0.001 + } + + # Restore last good fit and apply the Marquardt parameter. + call amovr (Memr[a2], Memr[a1], nfit * nfit) + call amovr (Memr[delta2], Memr[delta1], nfit) + do i = 1, nfit + Memr[a1+(i-1)*(nfit+1)] = Memr[a2+(i-1)*(nfit+1)] * (1. + mr) + + # Matrix solution. + call mr_invert (Memr[a1], Memr[delta1], nfit) + + # Compute the new values and curvature matrix. + do i = 1, nfit + Memr[new+flags[i]-1] = params[flags[i]] + Memr[delta1+i-1] + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a1], + Memr[delta1], nfit, chisq1) + + # Check if chisq has improved. + if (chisq1 < chisq) { + mr = max (EPSILONR, 0.1 * mr) + chisq = chisq1 + call amovr (Memr[a1], Memr[a2], nfit * nfit) + call amovr (Memr[delta1], Memr[delta2], nfit) + call amovr (Memr[new], params, np) + } else + mr = 10. * mr + + if (mr == 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + } +end + + +# MR_EVAL -- Evaluate curvature matrix. This calls procedure DERIVS. + +procedure mr_eval (x, y, npts, params, flags, np, a, delta, nfit, chisq) + +real x[npts] # X data array +real y[npts] # Y data array +int npts # Number of data points +real params[np] # Parameter array +int flags[np] # Flag array indexing parameters to fit +int np # Number of parameters +real a[nfit,nfit] # Curvature matrix +real delta[nfit] # Delta array +int nfit # Number of parameters to fit +real chisq # Chi square of fit + +int i, j, k +real ymod, dy, dydpj, dydpk +pointer sp, dydp + +begin + call smark (sp) + call salloc (dydp, np, TY_REAL) + + do j = 1, nfit { + do k = 1, j + a[j,k] = 0. + delta[j] = 0. + } + + chisq = 0. + do i = 1, npts { + call derivs (x[i], params, ymod, Memr[dydp], np) + dy = y[i] - ymod + do j = 1, nfit { + dydpj = Memr[dydp+flags[j]-1] + delta[j] = delta[j] + dy * dydpj + do k = 1, j { + dydpk = Memr[dydp+flags[k]-1] + a[j,k] = a[j,k] + dydpj * dydpk + } + } + chisq = chisq + dy * dy + } + + do j = 2, nfit + do k = 1, j-1 + a[k,j] = a[j,k] + + call sfree (sp) +end + + +# MR_INVERT -- Solve a set of linear equations using Householder transforms. + +procedure mr_invert (a, b, n) + +real a[n,n] # Input matrix and returned inverse +real b[n] # Input RHS vector and returned solution +int n # Dimension of input matrices + +int krank +real rnorm +pointer sp, h, g, ip + +begin + call smark (sp) + call salloc (h, n, TY_REAL) + call salloc (g, n, TY_REAL) + call salloc (ip, n, TY_INT) + + call hfti (a, n, n, n, b, n, 1, 1E-10, krank, rnorm, + Memr[h], Memr[g], Memi[ip]) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ielimexam.x b/pkg/images/tv/imexamine/ielimexam.x new file mode 100644 index 00000000..9b1c490d --- /dev/null +++ b/pkg/images/tv/imexamine/ielimexam.x @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + + +# IE_LIMEXAM -- Make a line plot +# If the line is INDEF then use the last line. + +procedure ie_limexam (gp, mode, ie, y) + +pointer gp # GIO pointer +int mode # Mode +pointer ie # Structure pointer +real y # Line + +real yavg, junk +int i, x1, x2, y1, y2, nx, ny, npts +pointer sp, title, im, data, ptr, xp, yp + +int clgpseti() +pointer clopset(), ie_gimage(), ie_gdata() + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + IE_PP(ie) = clopset ("limexam") + + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + ny = clgpseti (IE_PP(ie), "naverage") + x1 = INDEFI + x2 = INDEFI + y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 + y2 = IE_Y1(ie) + ny / 2 + 0.5 + yavg = (y1 + y2) / 2. + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + call smark (sp) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (xp, nx, TY_REAL) + + do i = 1, nx + call ie_mwctran (ie, real(i), yavg, Memr[xp+i-1], junk) + + if (ny > 1) { + ptr = data + call salloc (yp, nx, TY_REAL) + call amovr (Memr[ptr], Memr[yp], nx) + do i = 2, ny { + ptr = ptr + nx + call aaddr (Memr[ptr], Memr[yp], Memr[yp], nx) + } + call adivkr (Memr[yp], real (ny), Memr[yp], nx) + } else + yp = data + + call sprintf (Memc[title], IE_SZTITLE, "%s: Lines %d - %d\n%s") + call pargstr (IE_IMNAME(ie)) + call pargi (y1) + call pargi (y2) + call pargstr (IM_TITLE(im)) + + call ie_graph (gp, mode, IE_PP(ie), Memc[title], Memr[xp], + Memr[yp], nx, IE_XLABEL(ie), IE_XFORMAT(ie)) + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/iemw.x b/pkg/images/tv/imexamine/iemw.x new file mode 100644 index 00000000..185cfbaa --- /dev/null +++ b/pkg/images/tv/imexamine/iemw.x @@ -0,0 +1,191 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + + +# IE_MWINIT -- Initialize MWCS + +procedure ie_mwinit (ie) + +pointer ie # IMEXAM descriptor + +int i, j, wcsdim, mw_stati(), nowhite(), stridxs() +pointer im, mw, ctlw, ctwl, mw_openim(), mw_sctran() +pointer sp, axno, axval, str1, str2 +bool streq() +errchk mw_openim, mw_sctran + +begin + im = IE_IM(ie) + mw = IE_MW(ie) + + if (mw != NULL) { + call mw_close (mw) + IE_MW(ie) = mw + } + + IE_XLABEL(ie) = EOS + IE_YLABEL(ie) = EOS + call clgstr ("xformat", IE_XFORMAT(ie), IE_SZFORMAT) + call clgstr ("yformat", IE_YFORMAT(ie), IE_SZFORMAT) + i = nowhite (IE_XFORMAT(ie), IE_XFORMAT(ie), IE_SZFORMAT) + i = nowhite (IE_YFORMAT(ie), IE_YFORMAT(ie), IE_SZFORMAT) + + if (im == NULL || im == IE_DS(ie)) + return + + call smark (sp) + call salloc (axno, IM_MAXDIM, TY_INT) + call salloc (axval, IM_MAXDIM, TY_INT) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + mw = mw_openim (im) + call mw_seti (mw, MW_USEAXMAP, NO) + wcsdim = mw_stati (mw, MW_NDIM) + call mw_gaxmap (mw, Memi[axno], Memi[axval], wcsdim) + IE_P1(ie) = 1 + IE_P2(ie) = 2 + do i = 1, wcsdim { + j = Memi[axno+i-1] + if (j == 0) + IE_IN(ie,i) = 1 + else if (j == 1) + IE_P1(ie) = i + else if (j == 2) + IE_P2(ie) = i + } + ctlw = mw_sctran (mw, "logical", IE_WCSNAME(ie), 0) + ctwl = mw_sctran (mw, IE_WCSNAME(ie), "logical", 0) + + # Set coordinate labels and formats + i = IE_P1(ie) + j = IE_P2(ie) + if (streq (IE_WCSNAME(ie), "logical")) { + call strcpy ("Column (pixels)", IE_XLABEL(ie), IE_SZFNAME) + call strcpy ("Line (pixels)", IE_YLABEL(ie), IE_SZFNAME) + } else if (streq (IE_WCSNAME(ie), "physical")) { + if (i == 1) + call strcpy ("Column (pixels)", IE_XLABEL(ie), IE_SZFNAME) + else if (i == 2) + call strcpy ("Line (pixels)", IE_XLABEL(ie), IE_SZFNAME) + else + call strcpy ("Pixels", IE_XLABEL(ie), IE_SZFNAME) + if (j == 1) + call strcpy ("Column (pixels)", IE_YLABEL(ie), IE_SZFNAME) + else if (j == 2) + call strcpy ("Line (pixels)", IE_YLABEL(ie), IE_SZFNAME) + else + call strcpy ("Pixels", IE_YLABEL(ie), IE_SZFNAME) + } else { + ifnoerr (call mw_gwattrs (mw, i, "label", Memc[str1], SZ_LINE)) { + ifnoerr (call mw_gwattrs (mw, i, "units", Memc[str2],SZ_LINE)) { + call sprintf (IE_XLABEL(ie), IE_SZFNAME, "%s (%s)") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + } else { + call sprintf (IE_XLABEL(ie), IE_SZFNAME, "%s") + call pargstr (Memc[str1]) + } + } + if (IE_XFORMAT(ie) != '%') + ifnoerr (call mw_gwattrs (mw, i, "format", Memc[str1], SZ_LINE)) + call strcpy (Memc[str1], IE_XFORMAT(ie), IE_SZFORMAT) + + ifnoerr (call mw_gwattrs (mw, j, "label", Memc[str1], SZ_LINE)) { + ifnoerr (call mw_gwattrs (mw, j, "units", Memc[str2],SZ_LINE)) { + call sprintf (IE_YLABEL(ie), IE_SZFNAME, "%s (%s)") + call pargstr (Memc[str1]) + call pargstr (Memc[str2]) + } else { + call sprintf (IE_YLABEL(ie), IE_SZFNAME, "%s") + call pargstr (Memc[str1]) + } + } + if (IE_YFORMAT(ie) != '%') + ifnoerr (call mw_gwattrs (mw, j, "format", Memc[str1], SZ_LINE)) + call strcpy (Memc[str1], IE_YFORMAT(ie), IE_SZFORMAT) + + # Check for equitorial coordinate and reversed formats. + ifnoerr (call mw_gwattrs (mw, i, "axtype", Memc[str1], SZ_LINE)) + if ((streq(Memc[str1],"ra")&&stridxs("hm",IE_XFORMAT(ie))>0) || + (streq(Memc[str1],"dec")&&stridxs("HM",IE_XFORMAT(ie))>0)) { + call strcpy (IE_XFORMAT(ie), Memc[str1], IE_SZFORMAT) + call strcpy (IE_YFORMAT(ie), IE_XFORMAT(ie),IE_SZFORMAT) + call strcpy (Memc[str1], IE_YFORMAT(ie), IE_SZFORMAT) + } + } + + IE_MW(ie) = mw + IE_CTLW(ie) = ctlw + IE_CTWL(ie) = ctwl + IE_WCSDIM(ie) = wcsdim + + call sfree (sp) +end + + +# IE_MWCTRAN -- Evaluate MWCS coordinate + +procedure ie_mwctran (ie, xin, yin, xout, yout) + +pointer ie # IMEXAM descriptor +real xin, yin # Input coordinate +real xout, yout # Output coordinate + +begin + if (IE_MW(ie) == NULL) { + xout = xin + yout = yin + return + } + + IE_IN(ie,IE_P1(ie)) = xin + IE_IN(ie,IE_P2(ie)) = yin + call mw_ctranr (IE_CTLW(ie), IE_IN(ie,1), IE_OUT(ie,1), IE_WCSDIM(ie)) + xout = IE_OUT(ie,IE_P1(ie)) + yout = IE_OUT(ie,IE_P2(ie)) +end + + +# IE_IMWCTRAN -- Evaluate inverse MWCS coordinate + +procedure ie_imwctran (ie, xin, yin, xout, yout) + +pointer ie # IMEXAM descriptor +real xin, yin # Input coordinate +real xout, yout # Output coordinate + +begin + if (IE_MW(ie) == NULL) { + xout = xin + yout = yin + return + } + + IE_OUT(ie,IE_P1(ie)) = xin + IE_OUT(ie,IE_P2(ie)) = yin + call mw_ctranr (IE_CTWL(ie), IE_OUT(ie,1), IE_IN(ie,1), IE_WCSDIM(ie)) + xout = IE_IN(ie,IE_P1(ie)) + yout = IE_IN(ie,IE_P2(ie)) +end + + +# IE_IFORMATR -- Determine the inverse formatted real value +# This temporary routine is used to account for scaling of the H and M formats. + +real procedure ie_iformatr (value, format) + +real value # Value to be inverse formated +char format[ARB] # Format + +int strldxs() + +begin + if (!IS_INDEF(value) && strldxs ("HM", format) > 0) + return (value * 15.) + else + return (value) +end diff --git a/pkg/images/tv/imexamine/ieopenlog.x b/pkg/images/tv/imexamine/ieopenlog.x new file mode 100644 index 00000000..08f754f9 --- /dev/null +++ b/pkg/images/tv/imexamine/ieopenlog.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + + +# IE_OPENLOG -- Open the log file. + +procedure ie_openlog (ie) + +pointer ie #I imexamine descriptor + +int nowhite(), open() +errchk open, close + +begin + if (IE_LOGFD(ie) != NULL) { + call close (IE_LOGFD(ie)) + IE_LOGFD(ie) = NULL + } + + if (nowhite (IE_LOGFILE(ie), IE_LOGFILE(ie), SZ_FNAME) > 0) { + iferr { + IE_LOGFD(ie) = open (IE_LOGFILE(ie), APPEND, TEXT_FILE) + call printf ("Log file %s open\n") + call pargstr (IE_LOGFILE(ie)) + + if (IE_IM(ie) != NULL) { + call fprintf (IE_LOGFD(ie), "# [%d] %s - %s\n") + call pargi (IE_INDEX(ie)) + call pargstr (IE_IMNAME(ie)) + call pargstr (IM_TITLE(IE_IM(ie))) + } + + } then + call erract (EA_WARN) + } +end diff --git a/pkg/images/tv/imexamine/iepos.x b/pkg/images/tv/imexamine/iepos.x new file mode 100644 index 00000000..7253816b --- /dev/null +++ b/pkg/images/tv/imexamine/iepos.x @@ -0,0 +1,180 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + +# IE_POS -- Print cursor position and pixel value or set new origin. +# If the origin is not (0,0) print additional fields. + +procedure ie_pos (ie, x, y, key) + +pointer ie # IMEXAM structure +real x, y # Center of box +int key # Key ('x' positions, 'y' origin) + +pointer im, data +real dx, dy, r, t, wx, wy, xo, yo +int x1, x2, y1, y2 +pointer ie_gimage(), ie_gdata() + +begin + switch (key) { + case 'x': # Print position and pixel value + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + x1 = x + 0.5 + x2 = x + 0.5 + y1 = y + 0.5 + y2 = y + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + + call printf ("%7.2f %7.2f %7g") + call pargr (x) + call pargr (y) + call pargr (Memr[data]) + + # Print additional fields + if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { + dx = x - IE_XORIGIN(ie) + dy = y - IE_YORIGIN(ie) + r = sqrt (dx * dx + dy * dy) + t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) + call printf (" %7.f %7.2f %7.2f %7.2f %7.2f %5.1f") + call pargr (IE_XORIGIN(ie)) + call pargr (IE_YORIGIN(ie)) + call pargr (dx) + call pargr (dy) + call pargr (r) + call pargr (t) + } + call printf ("\n") + case 'y': # Set new origin + IE_XORIGIN(ie) = x + IE_YORIGIN(ie) = y + call printf ("Origin: %.2f %.2f\n") + call pargr (IE_XORIGIN(ie)) + call pargr (IE_YORIGIN(ie)) + } + + # Print to logfile if needed. + if (IE_LOGFD(ie) != NULL) { + switch (key) { + case 'x': + call fprintf (IE_LOGFD(ie), "%7.2f %7.2f %7g") + call pargr (x) + call pargr (y) + call pargr (Memr[data]) + if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { + dx = x - IE_XORIGIN(ie) + dy = y - IE_YORIGIN(ie) + r = sqrt (dx * dx + dy * dy) + t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) + call fprintf (IE_LOGFD(ie), + " %7.f %7.2f %7.2f %7.2f %7.2f %5.1f") + call pargr (IE_XORIGIN(ie)) + call pargr (IE_YORIGIN(ie)) + call pargr (dx) + call pargr (dy) + call pargr (r) + call pargr (t) + } + call fprintf (IE_LOGFD(ie), "\n") + case 'y': # Set new origin + IE_XORIGIN(ie) = x + IE_YORIGIN(ie) = y + call fprintf (IE_LOGFD(ie), "Origin: %.2f %.2f\n") + call pargr (IE_XORIGIN(ie)) + call pargr (IE_YORIGIN(ie)) + } + } + + # Print in WCS if necessary. + call ie_mwctran (ie, x, y, wx, wy) + if (x == wx && y == wy) + return + call ie_mwctran (ie, IE_XORIGIN(ie), IE_YORIGIN(ie), xo, yo) + + switch (key) { + case 'x': # Print position and pixel value + if (IE_XFORMAT(ie) == '%') + call printf (IE_XFORMAT(ie)) + else + call printf ("%7g") + call pargr (wx) + call printf (" ") + if (IE_YFORMAT(ie) == '%') + call printf (IE_YFORMAT(ie)) + else + call printf ("%7g") + call pargr (wy) + call printf (" %7g") + call pargr (Memr[data]) + + # Print additional fields + if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { + dx = wx - xo + dy = wy - yo + r = sqrt (dx * dx + dy * dy) + t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) + call printf (" %7g %7g %7g %7g %7g %5.1f") + call pargr (xo) + call pargr (yo) + call pargr (dx) + call pargr (dy) + call pargr (r) + call pargr (t) + } + call printf ("\n") + case 'y': # Set new origin + call printf ("Origin: %7g %7g\n") + call pargr (xo) + call pargr (yo) + } + + # Print to logfile if needed. + if (IE_LOGFD(ie) != NULL) { + switch (key) { + case 'x': + if (IE_XFORMAT(ie) == '%') + call fprintf (IE_LOGFD(ie), IE_XFORMAT(ie)) + else + call fprintf (IE_LOGFD(ie), "%7g") + call pargr (wx) + call fprintf (IE_LOGFD(ie), " ") + if (IE_YFORMAT(ie) == '%') + call fprintf (IE_LOGFD(ie), IE_YFORMAT(ie)) + else + call fprintf (IE_LOGFD(ie), "%7g") + call pargr (wy) + call fprintf (IE_LOGFD(ie), " %7g") + call pargr (Memr[data]) + + if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { + dx = wx - xo + dy = wy - yo + r = sqrt (dx * dx + dy * dy) + t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) + call fprintf (IE_LOGFD(ie), + " %7g %7g %7g %7g %7g %5.1f") + call pargr (xo) + call pargr (yo) + call pargr (dx) + call pargr (dy) + call pargr (r) + call pargr (t) + } + call fprintf (IE_LOGFD(ie), "\n") + case 'y': # Set new origin + call fprintf (IE_LOGFD(ie), "Origin: %7g %7g\n") + call pargr (xo) + call pargr (yo) + } + } +end diff --git a/pkg/images/tv/imexamine/ieprint.x b/pkg/images/tv/imexamine/ieprint.x new file mode 100644 index 00000000..0a7a7602 --- /dev/null +++ b/pkg/images/tv/imexamine/ieprint.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imexam.h" + +# IE_PRINT -- Print box of pixel values + +procedure ie_print (ie, x, y) + +pointer ie # IMEXAM structure +real x, y # Center of box + +int i, j, x1, x2, y1, y2, nx +pointer im, data, ie_gimage(), ie_gdata() + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + x1 = x - 5 + 0.5 + x2 = x + 5 + 0.5 + y1 = y - 5 + 0.5 + y2 = y + 5 + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + nx = x2 - x1 + 1 + + call printf ("%4w") + do i = x1, x2 { + call printf (" %4d ") + call pargi (i) + } + call printf ("\n") + + do j = y2, y1, -1 { + call printf ("%4d") + call pargi (j) + do i = x1, x2 { + call printf (" %5g") + call pargr (Memr[data+(j-y1)*nx+(i-x1)]) + } + call printf ("\n") + } + + if (IE_LOGFD(ie) != NULL) { + call fprintf (IE_LOGFD(ie), "%4w") + do i = x1, x2 { + call fprintf (IE_LOGFD(ie), " %4d ") + call pargi (i) + } + call fprintf (IE_LOGFD(ie), "\n") + + do j = y2, y1, -1 { + call fprintf (IE_LOGFD(ie), "%4d") + call pargi (j) + do i = x1, x2 { + call fprintf (IE_LOGFD(ie), " %5g") + call pargr (Memr[data+(j-y1)*nx+(i-x1)]) + } + call fprintf (IE_LOGFD(ie), "\n") + } + } +end diff --git a/pkg/images/tv/imexamine/ieqrimexam.x b/pkg/images/tv/imexamine/ieqrimexam.x new file mode 100644 index 00000000..68388874 --- /dev/null +++ b/pkg/images/tv/imexamine/ieqrimexam.x @@ -0,0 +1,489 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "imexam.h" + +define FITTYPES "|gaussian|moffat|" +define FITGAUSS 1 +define FITMOFFAT 2 + + +# IE_QRIMEXAM -- Radial profile plot and photometry parameters. +# If no GIO pointer is given then only the photometry parameters are printed. +# First find the center using the marginal distributions. Then subtract +# a fit to the background. Compute the moments within the aperture and +# fit a gaussian of fixed center and zero background. Make the plot +# and print the photometry values. + +procedure ie_qrimexam (gp, mode, ie, x, y) + +pointer gp +pointer ie +int mode +real x, y + +bool center, background, medsky, fitplot, clgpsetb() +real radius, buffer, width, magzero, rplot, beta, clgpsetr() +int fittype, xorder, yorder, clgpseti(), strdic() + +int i, j, ns, no, np, nx, ny, npts, x1, x2, y1, y2 +int plist[3], nplist +real bkg, xcntr, ycntr, mag, e, pa, zcntr, wxcntr, wycntr +real params[3] +real fwhm, dfwhm +pointer sp, fittypes, title, coords, im, data, pp, ws, xs, ys, zs, gs, ptr, nl +double sumo, sums, sumxx, sumyy, sumxy +real r, r1, r2, r3, dx, dy, gseval(), amedr() +pointer clopset(), ie_gimage(), ie_gdata(), locpr() +extern ie_gauss(), ie_dgauss(), ie_moffat(), ie_dmoffat() +errchk nlinit, nlfit + +string glabel "#\ + COL LINE RMAG FLUX SKY N RMOM ELLIP PA PEAK GFWHM\n" +string mlabel "#\ + COL LINE RMAG FLUX SKY N RMOM ELLIP PA PEAK MFWHM\n" + +begin + call smark (sp) + call salloc (fittypes, SZ_FNAME, TY_CHAR) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (coords, IE_SZTITLE, TY_CHAR) + + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + # Open parameter set. + if (gp != NULL) { + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + } + pp = clopset ("rimexam") + + center = clgpsetb (pp, "center") + background = clgpsetb (pp, "background") + radius = clgpsetr (pp, "radius") + buffer = clgpsetr (pp, "buffer") + width = clgpsetr (pp, "width") + xorder = clgpseti (pp, "xorder") + yorder = clgpseti (pp, "yorder") + medsky = (xorder <= 0 || yorder <= 0) + + magzero = clgpsetr (pp, "magzero") + rplot = clgpsetr (pp, "rplot") + fitplot = clgpsetb (pp, "fitplot") + call clgpseta (pp, "fittype", Memc[fittypes], SZ_FNAME) + fittype = strdic (Memc[fittypes], Memc[fittypes], SZ_FNAME, FITTYPES) + if (fittype == 0) { + call eprintf ("WARNING: Unknown profile fit type `%s'.\n") + call pargstr (Memc[fittypes]) + call sfree (sp) + return + } + beta = clgpsetr (pp, "beta") + + # If the initial center is INDEF then use the previous value. + if (gp != NULL) { + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + xcntr = IE_X1(ie) + ycntr = IE_Y1(ie) + } else { + xcntr = x + ycntr = y + } + + # Center + if (center) + iferr (call ie_center (im, radius, xcntr, ycntr)) { + call erract (EA_WARN) + return + } + + # Crude estimage of FHWM. + dfwhm = radius + + # Get data including a buffer and background annulus. + if (!background) { + buffer = 0. + width = 0. + } + r = max (rplot, radius + buffer + width) + x1 = xcntr - r + x2 = xcntr + r + y1 = ycntr - r + y2 = ycntr + r + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + call salloc (xs, npts, TY_REAL) + call salloc (ys, npts, TY_REAL) + call salloc (ws, npts, TY_REAL) + + # Extract the background data if background subtracting. + ns = 0 + if (background && width > 0.) { + call salloc (zs, npts, TY_REAL) + + r1 = radius ** 2 + r2 = (radius + buffer) ** 2 + r3 = (radius + buffer + width) ** 2 + + ptr = data + do j = y1, y2 { + dy = (ycntr - j) ** 2 + do i = x1, x2 { + r = (xcntr - i) ** 2 + dy + if (r <= r1) + ; + else if (r >= r2 && r <= r3) { + Memr[xs+ns] = i + Memr[ys+ns] = j + Memr[zs+ns] = Memr[ptr] + ns = ns + 1 + } + ptr = ptr + 1 + } + } + } + + # Accumulate the various sums for the moments and the gaussian fit. + no = 0 + np = 0 + zcntr = 0. + sumo = 0.; sums = 0.; sumxx = 0.; sumyy = 0.; sumxy = 0. + ptr = data + gs = NULL + + if (ns > 0) { # Background subtraction + + # If background points are defined fit a surface and subtract + # the fitted background from within the object aperture. + + if (medsky) + bkg = amedr (Memr[zs], ns) + else { + repeat { + call gsinit (gs, GS_POLYNOMIAL, xorder, yorder, YES, + real (x1), real (x2), real (y1), real (y2)) + call gsfit (gs, Memr[xs], Memr[ys], Memr[zs], Memr[ws], ns, + WTS_UNIFORM, i) + if (i == OK) + break + xorder = max (1, xorder - 1) + yorder = max (1, yorder - 1) + call gsfree (gs) + } + bkg = gseval (gs, real(x1), real(y1)) + } + + do j = y1, y2 { + dy = j - ycntr + do i = x1, x2 { + dx = i - xcntr + r = sqrt (dx ** 2 + dy ** 2) + r3 = max (0., min (5., 2 * r / dfwhm - 1.)) + + if (medsky) + r2 = bkg + else { + r2 = gseval (gs, real(i), real(j)) + bkg = min (bkg, r2) + } + r1 = Memr[ptr] - r2 + + if (r <= radius) { + sumo = sumo + r1 + sums = sums + r2 + sumxx = sumxx + dx * dx * r1 + sumyy = sumyy + dy * dy * r1 + sumxy = sumxy + dx * dy * r1 + zcntr = max (r1, zcntr) + if (r <= rplot) { + Memr[xs+no] = r + Memr[ys+no] = r1 + Memr[ws+no] = exp (-r3**2) / max (.1, r**2) + no = no + 1 + } else { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) + } + } else if (r <= rplot) { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + } + ptr = ptr + 1 + } + } + + if (gs != NULL) + call gsfree (gs) + + } else { # No background subtraction + bkg = 0. + do j = y1, y2 { + dy = j - ycntr + do i = x1, x2 { + dx = i - xcntr + r = sqrt (dx ** 2 + dy ** 2) + r3 = max (0., min (5., 2 * r / dfwhm - 1.)) + r1 = Memr[ptr] + + if (r <= radius) { + sumo = sumo + r1 + sumxx = sumxx + dx * dx * r1 + sumyy = sumyy + dy * dy * r1 + sumxy = sumxy + dx * dy * r1 + zcntr = max (r1, zcntr) + if (r <= rplot) { + Memr[xs+no] = r + Memr[ys+no] = r1 + Memr[ws+no] = exp (-r3**2) / max (.1, r**2) + no = no + 1 + } else { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) + } + } else if (r <= rplot) { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + } + ptr = ptr + 1 + } + } + } + if (np > 0) { + call amovr (Memr[xs+npts-np], Memr[xs+no], np) + call amovr (Memr[ys+npts-np], Memr[ys+no], np) + call amovr (Memr[ws+npts-np], Memr[ws+no], np) + } + if (rplot <= radius) { + no = no + np + np = no - np + } else + np = no + np + + + # Compute the photometry and gaussian fit parameters. + + switch (fittype) { + case FITGAUSS: + plist[1] = 1 + plist[2] = 2 + nplist = 2 + params[2] = dfwhm**2 / (8 * log(2.)) + params[1] = zcntr + call nlinitr (nl, locpr (ie_gauss), locpr (ie_dgauss), + params, params, 2, plist, nplist, .001, 100) + call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) + if (i == SINGULAR || i == NO_DEG_FREEDOM) { + call eprintf ("WARNING: Gaussian fit did not converge\n") + call tsleep (5) + zcntr = INDEF + fwhm = INDEF + } else { + call nlpgetr (nl, params, i) + if (params[2] < 0.) { + zcntr = INDEF + fwhm = INDEF + } else { + zcntr = params[1] + fwhm = sqrt (8 * log (2.) * params[2]) + } + } + case FITMOFFAT: + plist[1] = 1 + plist[2] = 2 + if (IS_INDEF(beta)) { + params[3] = -3.0 + plist[3] = 3 + nplist = 3 + } else { + params[3] = -beta + nplist = 2 + } + params[2] = dfwhm / 2. / sqrt (2.**(-1./params[3]) - 1.) + params[1] = zcntr + call nlinitr (nl, locpr (ie_moffat), locpr (ie_dmoffat), + params, params, 3, plist, nplist, .001, 100) + call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) + if (i == SINGULAR || i == NO_DEG_FREEDOM) { + call eprintf ("WARNING: Moffat fit did not converge\n") + call tsleep (5) + zcntr = INDEF + fwhm = INDEF + beta = INDEF + } else { + call nlpgetr (nl, params, i) + if (params[2] < 0.) { + zcntr = INDEF + fwhm = INDEF + beta = INDEF + } else { + zcntr = params[1] + beta = -params[3] + fwhm = abs (params[2])*2.*sqrt (2.**(-1./params[3]) - 1.) + } + } + } + + mag = INDEF + r = INDEF + e = INDEF + pa = INDEF + if (sumo > 0.) { + mag = magzero - 2.5 * log10 (sumo) + r2 = sumxx + sumyy + if (r2 > 0.) { + switch (fittype) { + case FITGAUSS: + r = 2 * sqrt (log (2.) * r2 / sumo) + case FITMOFFAT: + if (beta > 2.) + r = 2 * sqrt ((beta-2.)*(2.**(1./beta)-1) * r2 / sumo) + } + r1 =(sumxx-sumyy)**2+(2*sumxy)**2 + if (r1 > 0.) + e = sqrt (r1) / r2 + else + e = 0. + } + if (e < 0.01) + e = 0. + else + pa = RADTODEG (0.5 * atan2 (2*sumxy, sumxx-sumyy)) + } + + call ie_mwctran (ie, xcntr, ycntr, wxcntr, wycntr) + if (xcntr == wxcntr && ycntr == wycntr) + call strcpy ("%.2f %.2f", Memc[title], IE_SZTITLE) + else { + call sprintf (Memc[title], IE_SZTITLE, "%s %s") + if (IE_XFORMAT(ie) == '%') + call pargstr (IE_XFORMAT(ie)) + else + call pargstr ("%g") + if (IE_YFORMAT(ie) == '%') + call pargstr (IE_YFORMAT(ie)) + else + call pargstr ("%g") + } + call sprintf (Memc[coords], IE_SZTITLE, Memc[title]) + call pargr (wxcntr) + call pargr (wycntr) + + # Plot the radial profile and overplot the fit. + if (gp != NULL) { + call sprintf (Memc[title], IE_SZTITLE, + "%s: Radial profile at %s\n%s") + call pargstr (IE_IMNAME(ie)) + call pargstr (Memc[coords]) + call pargstr (IM_TITLE(im)) + + call ie_graph (gp, mode, pp, Memc[title], Memr[xs], Memr[ys], + np, "", "") + + if (fitplot && !IS_INDEF (fwhm)) { + np = 51 + dx = rplot / (np - 1) + do i = 0, np - 1 + Memr[xs+i] = i * dx + call nlvectorr (nl, Memr[xs], Memr[ys], np, 1) + call gseti (gp, G_PLTYPE, 2) + call gpline (gp, Memr[xs], Memr[ys], np) + call gseti (gp, G_PLTYPE, 1) + } + } + + if (IE_LASTKEY(ie) != ',') { + switch (fittype) { + case FITGAUSS: + call printf (glabel) + case FITMOFFAT: + call printf (mlabel) + } + } + + # Print the photometry values. + call printf ( + "%7.2f %7.2f %7.2f %8.1f %8.2f %3d %5.2f %5.3f %5.1f %8.2f %5.2f\n") + call pargr (xcntr) + call pargr (ycntr) + call pargr (mag) + call pargd (sumo) + call pargd (sums / no) + call pargi (no) + call pargr (r) + call pargr (e) + call pargr (pa) + call pargr (zcntr) + call pargr (fwhm) + if (gp == NULL) { + if (xcntr != wxcntr || ycntr != wycntr) { + call printf ("%s: %s\n") + call pargstr (IE_WCSNAME(ie)) + call pargstr (Memc[coords]) + } + } + + if (IE_LOGFD(ie) != NULL) { + if (IE_LASTKEY(ie) != ',') { + switch (fittype) { + case FITGAUSS: + call fprintf (IE_LOGFD(ie), glabel) + case FITMOFFAT: + call fprintf (IE_LOGFD(ie), mlabel) + } + } + + call fprintf (IE_LOGFD(ie), + "%7.2f %7.2f %7.2f %8.1f %8.2f %3d %5.2f %5.3f %5.1f %8.2f %5.2f\n") + call pargr (xcntr) + call pargr (ycntr) + call pargr (mag) + call pargd (sumo) + call pargd (sums / no) + call pargi (no) + call pargr (r) + call pargr (e) + call pargr (pa) + call pargr (zcntr) + call pargr (fwhm) + if (xcntr != wxcntr || ycntr != wycntr) { + call fprintf (IE_LOGFD(ie), "%s: %s\n") + call pargstr (IE_WCSNAME(ie)) + call pargstr (Memc[coords]) + } + } + + if (gp == NULL) + call clcpset (pp) + else + IE_PP(ie) = pp + + call nlfreer (nl) + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ierimexam.x b/pkg/images/tv/imexamine/ierimexam.x new file mode 100644 index 00000000..f76ff507 --- /dev/null +++ b/pkg/images/tv/imexamine/ierimexam.x @@ -0,0 +1,752 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include "imexam.h" + +define FITTYPES "|gaussian|moffat|" +define FITGAUSS 1 +define FITMOFFAT 2 + + +# IE_RIMEXAM -- Radial profile plot and photometry parameters. +# If no GIO pointer is given then only the photometry parameters are printed. +# First find the center using the marginal distributions. Then subtract +# a fit to the background. Compute the moments within the aperture and +# fit a gaussian of fixed center and zero background. Make the plot +# and print the photometry values. + +procedure ie_rimexam (gp, mode, ie, x, y) + +pointer gp +pointer ie +int mode +real x, y + +bool center, background, medsky, fitplot, clgpsetb() +real radius, buffer, width, magzero, rplot, beta, clgpsetr() +int nit, fittype, xorder, yorder, clgpseti(), strdic() + +int i, j, ns, no, np, nx, ny, npts, x1, x2, y1, y2 +int coordlen, plist[3], nplist, strlen() +real bkg, xcntr, ycntr, mag, e, pa, zcntr, wxcntr, wycntr +real params[3] +real fwhm, dbkg, dfwhm, gfwhm, efwhm +pointer sp, fittypes, title, coords, im, data, pp, ws, xs, ys, zs, gs, ptr, nl +double sumo, sums, sumxx, sumyy, sumxy +real r, r1, r2, r3, dx, dy, gseval(), amedr() +pointer clopset(), ie_gimage(), ie_gdata(), locpr() +extern ie_gauss(), ie_dgauss(), ie_moffat(), ie_dmoffat() +errchk stf_measure, nlinit, nlfit + +begin + call smark (sp) + call salloc (fittypes, SZ_FNAME, TY_CHAR) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (coords, IE_SZTITLE, TY_CHAR) + + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + # Open parameter set. + if (gp != NULL) { + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + } + pp = clopset ("rimexam") + + center = clgpsetb (pp, "center") + background = clgpsetb (pp, "background") + radius = clgpsetr (pp, "radius") + buffer = clgpsetr (pp, "buffer") + width = clgpsetr (pp, "width") + xorder = clgpseti (pp, "xorder") + yorder = clgpseti (pp, "yorder") + medsky = (xorder <= 0 || yorder <= 0) + nit = clgpseti (pp, "iterations") + + magzero = clgpsetr (pp, "magzero") + rplot = clgpsetr (pp, "rplot") + fitplot = clgpsetb (pp, "fitplot") + call clgpseta (pp, "fittype", Memc[fittypes], SZ_FNAME) + fittype = strdic (Memc[fittypes], Memc[fittypes], SZ_FNAME, FITTYPES) + if (fittype == 0) { + call eprintf ("WARNING: Unknown profile fit type `%s'.\n") + call pargstr (Memc[fittypes]) + call sfree (sp) + return + } + beta = clgpsetr (pp, "beta") + + # If the initial center is INDEF then use the previous value. + if (gp != NULL) { + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + xcntr = IE_X1(ie) + ycntr = IE_Y1(ie) + } else { + xcntr = x + ycntr = y + } + + # Center + if (center) + iferr (call ie_center (im, radius, xcntr, ycntr)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + # Do the enclosed flux and direct FWHM measurments using the + # PSFMEASURE routines. + + call stf_measure (im, xcntr, ycntr, beta, 0.5, radius, nit, buffer, + width, INDEF, NULL, NULL, dbkg, r, dfwhm, gfwhm, efwhm) + if (fittype == FITGAUSS) + efwhm = gfwhm + + # Get data including a buffer and background annulus. + if (!background) { + buffer = 0. + width = 0. + } + r = max (rplot, radius + buffer + width) + x1 = xcntr - r + x2 = xcntr + r + y1 = ycntr - r + y2 = ycntr + r + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + call salloc (xs, npts, TY_REAL) + call salloc (ys, npts, TY_REAL) + call salloc (ws, npts, TY_REAL) + + # Extract the background data if background subtracting. + ns = 0 + if (background && width > 0.) { + call salloc (zs, npts, TY_REAL) + + r1 = radius ** 2 + r2 = (radius + buffer) ** 2 + r3 = (radius + buffer + width) ** 2 + + ptr = data + do j = y1, y2 { + dy = (ycntr - j) ** 2 + do i = x1, x2 { + r = (xcntr - i) ** 2 + dy + if (r <= r1) + ; + else if (r >= r2 && r <= r3) { + Memr[xs+ns] = i + Memr[ys+ns] = j + Memr[zs+ns] = Memr[ptr] + ns = ns + 1 + } + ptr = ptr + 1 + } + } + } + + # Accumulate the various sums for the moments and the gaussian fit. + no = 0 + np = 0 + zcntr = 0. + sumo = 0.; sums = 0.; sumxx = 0.; sumyy = 0.; sumxy = 0. + ptr = data + gs = NULL + + if (ns > 0) { # Background subtraction + + # If background points are defined fit a surface and subtract + # the fitted background from within the object aperture. + + if (medsky) + bkg = amedr (Memr[zs], ns) + else { + repeat { + call gsinit (gs, GS_POLYNOMIAL, xorder, yorder, YES, + real (x1), real (x2), real (y1), real (y2)) + call gsfit (gs, Memr[xs], Memr[ys], Memr[zs], Memr[ws], ns, + WTS_UNIFORM, i) + if (i == OK) + break + xorder = max (1, xorder - 1) + yorder = max (1, yorder - 1) + call gsfree (gs) + } + bkg = gseval (gs, real(x1), real(y1)) + } + + do j = y1, y2 { + dy = j - ycntr + do i = x1, x2 { + dx = i - xcntr + r = sqrt (dx ** 2 + dy ** 2) + r3 = max (0., min (5., 2 * r / dfwhm - 1.)) + + if (medsky) + r2 = bkg + else { + r2 = gseval (gs, real(i), real(j)) + bkg = min (bkg, r2) + } + r1 = Memr[ptr] - r2 + + if (r <= radius) { + sumo = sumo + r1 + sums = sums + r2 + sumxx = sumxx + dx * dx * r1 + sumyy = sumyy + dy * dy * r1 + sumxy = sumxy + dx * dy * r1 + zcntr = max (r1, zcntr) + if (r <= rplot) { + Memr[xs+no] = r + Memr[ys+no] = r1 + Memr[ws+no] = exp (-r3**2) / max (.1, r**2) + no = no + 1 + } else { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) + } + } else if (r <= rplot) { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + } + ptr = ptr + 1 + } + } + + if (gs != NULL) + call gsfree (gs) + + } else { # No background subtraction + bkg = 0. + do j = y1, y2 { + dy = j - ycntr + do i = x1, x2 { + dx = i - xcntr + r = sqrt (dx ** 2 + dy ** 2) + r3 = max (0., min (5., 2 * r / dfwhm - 1.)) + r1 = Memr[ptr] + + if (r <= radius) { + sumo = sumo + r1 + sumxx = sumxx + dx * dx * r1 + sumyy = sumyy + dy * dy * r1 + sumxy = sumxy + dx * dy * r1 + zcntr = max (r1, zcntr) + if (r <= rplot) { + Memr[xs+no] = r + Memr[ys+no] = r1 + Memr[ws+no] = exp (-r3**2) / max (.1, r**2) + no = no + 1 + } else { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) + } + } else if (r <= rplot) { + np = np + 1 + Memr[xs+npts-np] = r + Memr[ys+npts-np] = r1 + } + ptr = ptr + 1 + } + } + } + if (np > 0) { + call amovr (Memr[xs+npts-np], Memr[xs+no], np) + call amovr (Memr[ys+npts-np], Memr[ys+no], np) + call amovr (Memr[ws+npts-np], Memr[ws+no], np) + } + if (rplot <= radius) { + no = no + np + np = no - np + } else + np = no + np + + + # Compute the photometry and profile fit parameters. + + switch (fittype) { + case FITGAUSS: + plist[1] = 1 + plist[2] = 2 + nplist = 2 + params[2] = dfwhm**2 / (8 * log(2.)) + params[1] = zcntr + call nlinitr (nl, locpr (ie_gauss), locpr (ie_dgauss), + params, params, 2, plist, nplist, .001, 100) + call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) + if (i == SINGULAR || i == NO_DEG_FREEDOM) { + call eprintf ("WARNING: Gaussian fit did not converge\n") + call tsleep (5) + zcntr = INDEF + fwhm = INDEF + } else { + call nlpgetr (nl, params, i) + if (params[2] < 0.) { + zcntr = INDEF + fwhm = INDEF + } else { + zcntr = params[1] + fwhm = sqrt (8 * log (2.) * params[2]) + } + } + case FITMOFFAT: + plist[1] = 1 + plist[2] = 2 + if (IS_INDEF(beta)) { + params[3] = -3.0 + plist[3] = 3 + nplist = 3 + } else { + params[3] = -beta + nplist = 2 + } + params[2] = dfwhm / 2. / sqrt (2.**(-1./params[3]) - 1.) + params[1] = zcntr + call nlinitr (nl, locpr (ie_moffat), locpr (ie_dmoffat), + params, params, 3, plist, nplist, .001, 100) + call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) + if (i == SINGULAR || i == NO_DEG_FREEDOM) { + call eprintf ("WARNING: Moffat fit did not converge\n") + call tsleep (5) + zcntr = INDEF + fwhm = INDEF + beta = INDEF + } else { + call nlpgetr (nl, params, i) + if (params[2] < 0.) { + zcntr = INDEF + fwhm = INDEF + beta = INDEF + } else { + zcntr = params[1] + beta = -params[3] + fwhm = abs (params[2])*2.*sqrt (2.**(-1./params[3]) - 1.) + } + } + } + + mag = INDEF + r = INDEF + e = INDEF + pa = INDEF + if (sumo > 0.) { + mag = magzero - 2.5 * log10 (sumo) + r2 = sumxx + sumyy + if (r2 > 0.) { + switch (fittype) { + case FITGAUSS: + r = 2 * sqrt (log (2.) * r2 / sumo) + case FITMOFFAT: + if (beta > 2.) + r = 2 * sqrt ((beta-2.)*(2.**(1./beta)-1) * r2 / sumo) + } + r1 =(sumxx-sumyy)**2+(2*sumxy)**2 + if (r1 > 0.) + e = sqrt (r1) / r2 + else + e = 0. + } + if (e < 0.01) + e = 0. + else + pa = RADTODEG (0.5 * atan2 (2*sumxy, sumxx-sumyy)) + } + + call ie_mwctran (ie, xcntr, ycntr, wxcntr, wycntr) + if (xcntr == wxcntr && ycntr == wycntr) + call strcpy ("%.2f %.2f", Memc[title], IE_SZTITLE) + else { + call sprintf (Memc[title], IE_SZTITLE, "%s %s") + if (IE_XFORMAT(ie) == '%') + call pargstr (IE_XFORMAT(ie)) + else + call pargstr ("%g") + if (IE_YFORMAT(ie) == '%') + call pargstr (IE_YFORMAT(ie)) + else + call pargstr ("%g") + } + call sprintf (Memc[coords], IE_SZTITLE, Memc[title]) + call pargr (wxcntr) + call pargr (wycntr) + + # Plot the radial profile and overplot the gaussian fit. + if (gp != NULL) { + call sprintf (Memc[title], IE_SZTITLE, + "%s: Radial profile at %s\n%s") + call pargstr (IE_IMNAME(ie)) + call pargstr (Memc[coords]) + call pargstr (IM_TITLE(im)) + + call ie_graph (gp, mode, pp, Memc[title], Memr[xs], Memr[ys], + np, "", "") + + if (fitplot && !IS_INDEF (fwhm)) { + np = 51 + dx = rplot / (np - 1) + do i = 0, np - 1 + Memr[xs+i] = i * dx + call nlvectorr (nl, Memr[xs], Memr[ys], np, 1) + call gseti (gp, G_PLTYPE, 2) + call gpline (gp, Memr[xs], Memr[ys], np) + call gseti (gp, G_PLTYPE, 1) + } + call gseti (gp, G_PLTYPE, 2) + + call printf ("%6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") + call pargr (radius) + call pargr (mag) + call pargd (sumo) + call pargd (sums / no) + call pargr (zcntr) + call pargr (e) + call pargr (pa) + switch (fittype) { + case FITGAUSS: + call printf (" %4w %8.2f %8.2f %6.2f\n") + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + case FITMOFFAT: + call printf (" %4.2f %8.2f %8.2f %6.2f\n") + call pargr (beta) + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + } + + } else { + if (IE_LASTKEY(ie) != 'a') { + coordlen = max (11, strlen (Memc[coords])) + call printf ("# %5s %7s %-*s\n# %5s %6s %7s %7s %7s %4s %4s") + call pargstr ("COL") + call pargstr ("LINE") + call pargi (coordlen) + call pargstr ("COORDINATES") + call pargstr ("R") + call pargstr ("MAG") + call pargstr ("FLUX") + call pargstr ("SKY") + call pargstr ("PEAK") + call pargstr ("E") + call pargstr ("PA") + switch (fittype) { + case FITGAUSS: + call printf (" %4w %8s %8s %6s\n") + call pargstr ("ENCLOSED") + call pargstr ("GAUSSIAN") + call pargstr ("DIRECT") + case FITMOFFAT: + call printf (" %4s %8s %8s %6s\n") + call pargstr ("BETA") + call pargstr ("ENCLOSED") + call pargstr ("MOFFAT") + call pargstr ("DIRECT") + } + } + + call printf ( + "%7.2f %7.2f %-*s\n %6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") + call pargr (xcntr) + call pargr (ycntr) + call pargi (coordlen) + call pargstr (Memc[coords]) + call pargr (radius) + call pargr (mag) + call pargd (sumo) + call pargd (sums / no) + call pargr (zcntr) + call pargr (e) + call pargr (pa) + switch (fittype) { + case FITGAUSS: + call printf (" %4w %8.2f %8.2f %6.2f\n") + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + case FITMOFFAT: + call printf (" %4.2f %8.2f %8.2f %6.2f\n") + call pargr (beta) + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + } + } + + if (IE_LOGFD(ie) != NULL) { + if (IE_LASTKEY(ie) != 'a') { + coordlen = max (11, strlen (Memc[coords])) + call fprintf (IE_LOGFD(ie), + "# %5s %7s %-*s %6s %6s %7s %7s %7s %4s %4s") + call pargstr ("COL") + call pargstr ("LINE") + call pargi (coordlen) + call pargstr ("COORDINATES") + call pargstr ("R") + call pargstr ("MAG") + call pargstr ("FLUX") + call pargstr ("SKY") + call pargstr ("PEAK") + call pargstr ("E") + call pargstr ("PA") + switch (fittype) { + case FITGAUSS: + call fprintf (IE_LOGFD(ie), " %4w %8s %8s %6s\n") + call pargstr ("ENCLOSED") + call pargstr ("GAUSSIAN") + call pargstr ("DIRECT") + case FITMOFFAT: + call fprintf (IE_LOGFD(ie), " %4s %8s %8s %6s\n") + call pargstr ("BETA") + call pargstr ("ENCLOSED") + call pargstr ("MOFFAT") + call pargstr ("DIRECT") + } + } + + call fprintf (IE_LOGFD(ie), + "%7.2f %7.2f %-*s %6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") + call pargr (xcntr) + call pargr (ycntr) + call pargi (coordlen) + call pargstr (Memc[coords]) + call pargr (radius) + call pargr (mag) + call pargd (sumo) + call pargd (sums / no) + call pargr (zcntr) + call pargr (e) + call pargr (pa) + switch (fittype) { + case FITGAUSS: + call fprintf (IE_LOGFD(ie), " %4w %8.2f %8.2f %6.2f\n") + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + case FITMOFFAT: + call fprintf (IE_LOGFD(ie), " %4.2f %8.2f %8.2f %6.2f\n") + call pargr (beta) + call pargr (efwhm) + call pargr (fwhm) + call pargr (dfwhm) + } + } + + if (gp == NULL) + call clcpset (pp) + else + IE_PP(ie) = pp + + call nlfreer (nl) + call sfree (sp) +end + + +# IE_CENTER -- Find the center of gravity from the marginal distributions. + +procedure ie_center (im, radius, xcntr, ycntr) + +pointer im +real radius +real xcntr, ycntr + +int i, j, k, x1, x2, y1, y2, nx, ny, npts +real xlast, ylast +real mean, sum, sum1, sum2, sum3, asumr() +pointer data, ptr, ie_gdata() +errchk ie_gdata + +begin + # Find the center of a star image given approximate coords. Uses + # Mountain Photometry Code Algorithm as outlined in Stellar Magnitudes + # from Digital Images. + + do k = 1, 3 { + # Extract region around center + xlast = xcntr + ylast = ycntr + x1 = xcntr - radius + 0.5 + x2 = xcntr + radius + 0.5 + y1 = ycntr - radius + 0.5 + y2 = ycntr + radius + 0.5 + data = ie_gdata (im, x1, x2, y1, y2) + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + # Find center of gravity for marginal distributions above mean. + sum = asumr (Memr[data], npts) + mean = sum / nx + sum1 = 0. + sum2 = 0. + + do i = x1, x2 { + ptr = data + i - x1 + sum3 = 0. + do j = y1, y2 { + sum3 = sum3 + Memr[ptr] + ptr = ptr + nx + } + sum3 = sum3 - mean + if (sum3 > 0.) { + sum1 = sum1 + i * sum3 + sum2 = sum2 + sum3 + } + } + xcntr = sum1 / sum2 + + ptr = data + mean = sum / ny + sum1 = 0. + sum2 = 0. + do j = y1, y2 { + sum3 = 0. + do i = x1, x2 { + sum3 = sum3 + Memr[ptr] + ptr = ptr + 1 + } + sum3 = sum3 - mean + if (sum3 > 0.) { + sum1 = sum1 + j * sum3 + sum2 = sum2 + sum3 + } + } + ycntr = sum1 / sum2 + + if (int(xcntr) == int(xlast) && int(ycntr) == int(ylast)) + break + } +end + + +# IE_GAUSS -- Gaussian function used in NLFIT. The parameters are the +# amplitude and sigma squared and the input variable is the radius. + +procedure ie_gauss (x, nvars, p, np, z) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +int np #I Number of parameters +real z #O Function return + +real r2 + +begin + r2 = x[1]**2 / (2 * p[2]) + if (abs (r2) > 20.) + z = 0. + else + z = p[1] * exp (-r2) +end + + +# IE_DGAUSS -- Gaussian function and derivatives used in NLFIT. The parameters +# are the amplitude and sigma squared and the input variable is the radius. + +procedure ie_dgauss (x, nvars, p, dp, np, z, der) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +real dp[np] #I Dummy array of parameters increments +int np #I Number of parameters +real z #O Function return +real der[np] #O Derivatives + +real r2 + +begin + r2 = x[1]**2 / (2 * p[2]) + if (abs (r2) > 20.) { + z = 0. + der[1] = 0. + der[2] = 0. + } else { + der[1] = exp (-r2) + z = p[1] * der[1] + der[2] = z * r2 / p[2] + } +end + + +# IE_MOFFAT -- Moffat function used in NLFIT. The parameters are the +# amplitude, alpha squared, and beta and the input variable is the radius. + +procedure ie_moffat (x, nvars, p, np, z) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +int np #I Number of parameters +real z #O Function return + +real y + +begin + y = 1 + (x[1] / p[2]) ** 2 + if (abs (y) > 20.) + z = 0. + else + z = p[1] * y ** p[3] +end + + +# IE_DMOFFAT -- Moffat function and derivatives used in NLFIT. The parameters +# are the amplitude, alpha squared, and beta and the input variable is the +# radius. + +procedure ie_dmoffat (x, nvars, p, dp, np, z, der) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +real dp[np] #I Dummy array of parameters increments +int np #I Number of parameters +real z #O Function return +real der[np] #O Derivatives + +real y + +begin + y = 1 + (x[1] / p[2]) ** 2 + if (abs (y) > 20.) { + z = 0. + der[1] = 0. + der[2] = 0. + der[3] = 0. + } else { + der[1] = y ** p[3] + z = p[1] * der[1] + der[2] = -2 * z / y * p[3] / p[2] * (x[1] / p[2]) ** 2 + der[3] = z * log (y) + } +end diff --git a/pkg/images/tv/imexamine/iesimexam.x b/pkg/images/tv/imexamine/iesimexam.x new file mode 100644 index 00000000..292364ee --- /dev/null +++ b/pkg/images/tv/imexamine/iesimexam.x @@ -0,0 +1,492 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "imexam.h" + +define CSIZE 24 + + +# IE_SIMEXAM -- Draw a perspective view of a surface. The altitude +# and azimuth of the viewing angle are variable. + +procedure ie_simexam (gp, mode, ie, x, y) + +pointer gp # GIO pointer +int mode # Mode +pointer ie # IMEXAM pointer +real x, y # Center + +real angh, angv # Orientation of surface (degrees) +real floor, ceiling # Range limits + +int wkid +int x1, x2, y1, y2, nx, ny, npts +pointer pp, sp, title, str, sdata, work, im, data, ie_gimage(), ie_gdata() + +bool clgpsetb() +int clgpseti() +real clgpsetr() +pointer clopset() + +int first +real vpx1, vpx2, vpy1, vpy2 +common /frstfg/ first +common /noaovp/ vpx1, vpx2, vpy1, vpy2 + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + pp = IE_PP(ie) + if (pp != NULL) + call clcpset (pp) + pp = clopset ("simexam") + IE_PP(ie) = pp + + nx = clgpseti (pp, "ncolumns") + ny = clgpseti (pp, "nlines") + angh = clgpsetr (pp, "angh") + angv = clgpsetr (pp, "angv") + floor = clgpsetr (pp, "floor") + ceiling = clgpsetr (pp, "ceiling") + + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 + x2 = IE_X1(ie) + nx / 2 + 0.5 + y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 + y2 = IE_Y1(ie) + ny / 2 + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + call smark (sp) + + # Take floor and ceiling if enabled (nonzero). + if (IS_INDEF (floor) && IS_INDEF (ceiling)) + sdata = data + else { + call salloc (sdata, npts, TY_REAL) + call amovr (Memr[data], Memr[sdata], npts) + if (!IS_INDEF (floor) && !IS_INDEF (ceiling)) { + floor = min (floor, ceiling) + ceiling = max (floor, ceiling) + } + } + iferr (call ie_surf_limits (Memr[sdata], npts, floor, ceiling)) { + call sfree (sp) + call erract (EA_WARN) + return + } + + if (mode != APPEND) { + call gclear (gp) + + # Set the viewport. + call gsview (gp, 0.1, 0.9, 0.1, 0.9) + + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + if (clgpsetb (pp, "banner")) { + call sysid (Memc[str], SZ_LINE) + call sprintf (Memc[title], IE_SZTITLE, + "%s\n%s: Surface plot of [%d:%d,%d:%d]\n%s") + call pargstr (Memc[str]) + call pargstr (IE_IMNAME(ie)) + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + call pargstr (IM_TITLE(im)) + } else + Memc[title] = EOS + + call clgpset (pp, "title", Memc[str], SZ_LINE) + if (Memc[str] != EOS) { + call strcat ("\n", Memc[title], IE_SZTITLE) + call strcat (Memc[str], Memc[title], IE_SZTITLE) + } + + call gseti (gp, G_DRAWAXES, NO) + call glabax (gp, Memc[title], "", "") + } + + # Open graphics device and make plot. + call gopks (STDERR) + wkid = 1 + call gopwk (wkid, 6, gp) + call gacwk (wkid) + + first = 1 + call srfabd() + call ggview (gp, vpx1, vpx2, vpy1, vpy2) + call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) + call salloc (work, 2 * (2*nx*ny+nx+ny), TY_REAL) + call ezsrfc (Memr[sdata], nx, ny, angh, angv, Memr[work]) + + if (mode != APPEND) { + if (clgpsetb (pp, "axes")) { + call gswind (gp, real (x1), real (x2), real (y1), real (y2)) + call gseti (gp, G_CLIP, NO) + call ie_perimeter (gp, Memr[sdata], nx, ny, angh, angv) + } + } + + call gdawk (wkid) + call gclks () + call sfree (sp) +end + + +# IE_PERIMETER -- draw and label axes around the surface plot. + +procedure ie_perimeter (gp, z, ncols, nlines, angh, angv) + +pointer gp # Graphics pointer +int ncols # Number of image columns +int nlines # Number of image lines +real z[ncols, nlines] # Array of intensity values +real angh # Angle of horizontal inclination +real angv # Angle of vertical inclination + +pointer sp, x_val, y_val, kvec +char tlabel[10] +real xmin, ymin, delta, fact1, flo, hi, xcen, ycen +real x1_perim, x2_perim, y1_perim, y2_perim, z1, z2 +real wc1, wc2, wl1, wl2, del +int i, j, junk +int itoc() +data fact1 /2.0/ +real vpx1, vpx2, vpy1, vpy2 +common /noaovp/ vpx1, vpx2, vpy1, vpy2 + +begin + call smark (sp) + call salloc (x_val, ncols + 2, TY_REAL) + call salloc (y_val, nlines + 2, TY_REAL) + call salloc (kvec, max (ncols, nlines) + 2, TY_REAL) + + # Get window coordinates set up in calling procedure. + call ggwind (gp, wc1, wc2, wl1, wl2) + + # Set up window, viewport for output. The coordinates returned + # from trn32s are in the range [1-1024]. + call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) + + # Find range of z for determining perspective + flo = MAX_REAL + hi = -flo + do j = 1, nlines { + call alimr (z[1,j], ncols, z1, z2) + flo = min (flo, z1) + hi = max (hi, z2) + } + + # Set up linear endpoints and spacing as used in surface. + + delta = (hi-flo) / (max (ncols,nlines) -1.) * fact1 + xmin = -(real (ncols/2) * delta + real (mod (ncols+1, 2)) * delta) + ymin = -(real (nlines/2) * delta + real (mod (nlines+1, 2)) * delta) + del = 2.0 * delta + + # The perimeter is separated from the surface plot by the + # width of delta. + + x1_perim = xmin - delta + y1_perim = ymin - delta + x2_perim = xmin + (real (ncols) * delta) + y2_perim = ymin + (real (nlines) * delta) + # Set up linear arrays over full perimeter range + do i = 1, ncols + 2 + Memr[x_val+i-1] = x1_perim + (i-1) * delta + do i = 1, nlines + 2 + Memr[y_val+i-1] = y1_perim + (i-1) * delta + + # Draw and label axes and tick marks. + # It is important that frame has not been called after calling srface. + # First to draw the perimeter. Which axes get drawn depends on the + # values of angh and angv. Get angles in the range [-180, 180]. + + if (angh > 180.) + angh = angh - 360. + else if (angh < -180.) + angh = angh + 360. + + if (angv > 180.) + angv = angv - 360. + else if (angv < -180.) + angv = angv + 360. + + # Calculate positions for the axis labels + xcen = 0.5 * (x1_perim + x2_perim) + ycen = 0.5 * (y1_perim + y2_perim) + + if (angh >= 0) { + if (angv >= 0) { + # Case 1: xy rotation positive, looking down from above mid Z + + # First draw x axis + call amovkr (y2_perim, Memr[kvec], ncols + 2) + call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1) + call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", -1, -2) + call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta, + flo, ncols) + junk = itoc (int (wc1), tlabel, 10) + call ie_label_axis (xmin, y2_perim+del, flo, tlabel, -1, -2) + junk = itoc (int (wc2), tlabel, 10) + call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo, + tlabel, -1, -2) + + # Now draw y axis + call amovkr (x2_perim, Memr[kvec], nlines + 2) + call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1) + call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1) + call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1], + flo, nlines) + junk = itoc (int (wl1), tlabel, 10) + call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1) + junk = itoc (int (wl2), tlabel, 10) + call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo, + tlabel, 2, -1) + } else { + # Case 2: xy rotation positive, looking up from below mid Z + # First draw x axis + call amovkr (y1_perim, Memr[kvec], ncols + 2) + call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1) + call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", -1, 2) + call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta, + flo, ncols) + junk = itoc (int (wc1), tlabel, 10) + call ie_label_axis (xmin, y1_perim-del, flo, tlabel, -1, 2) + junk = itoc (int (wc2), tlabel, 10) + call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo, + tlabel, -1, 2) + + # Now draw y axis + call amovkr (x1_perim, Memr[kvec], nlines + 2) + call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1) + call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1) + call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1], + flo, nlines) + junk = itoc (int (wl1), tlabel, 10) + call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1) + junk = itoc (int (wl2), tlabel, 10) + call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo, + tlabel, 2, 1) + } + } + + if (angh < 0) { + if (angv > 0) { + # Case 3: xy rotation negative, looking down from above mid Z + # (default). First draw x axis + call amovkr (y1_perim, Memr[kvec], ncols + 2) + call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1) + call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", 1, 2) + call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta, + flo, ncols) + junk = itoc (int (wc1), tlabel, 10) + call ie_label_axis (xmin, y1_perim-del, flo, tlabel, 1, 2) + junk = itoc (int (wc2), tlabel, 10) + call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo, + tlabel, 1, 2) + + # Now draw y axis + call amovkr (x2_perim, Memr[kvec], nlines + 2) + call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1) + call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1) + call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1], + flo, nlines) + junk = itoc (int (wl1), tlabel, 10) + call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1) + junk = itoc (int (wl2), tlabel, 10) + call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo, + tlabel, 2, -1) + } else { + # Case 4: xy rotation negative, looking up from below mid Z + # First draw x axis + call amovkr (y2_perim, Memr[kvec], ncols + 2) + call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1) + call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", 1, -2) + call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta, + flo, ncols) + junk = itoc (int (wc1), tlabel, 10) + call ie_label_axis (xmin, y2_perim+del, flo, tlabel, 1, -2) + junk = itoc (int (wc2), tlabel, 10) + call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo, + tlabel, 1, -2) + + # Now draw y axis + call amovkr (x1_perim, Memr[kvec], nlines + 2) + call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1) + call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1) + call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1], + flo, nlines) + junk = itoc (int (wl1), tlabel, 10) + call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1) + junk = itoc (int (wl2), tlabel, 10) + call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo, + tlabel, 2, 1) + } + } + + # Flush plotit buffer before returning + call plotit (0, 0, 2) + call sfree (sp) +end + + +# ?? + +procedure ie_draw_axis (xvals, yvals, zval, nvals) + +int nvals +real xvals[nvals] +real yvals[nvals] +real zval +pointer sp, xt, yt +int i +real dum + +begin + call smark (sp) + call salloc (xt, nvals, TY_REAL) + call salloc (yt, nvals, TY_REAL) + + do i = 1, nvals + call trn32s (xvals[i], yvals[i], zval, Memr[xt+i-1], Memr[yt+i-1], + dum, 1) + + call gpl (nvals, Memr[xt], Memr[yt]) + call sfree (sp) +end + + +# ?? + +procedure ie_label_axis (xval, yval, zval, sppstr, path, up) + +real xval +real yval +real zval +char sppstr[SZ_LINE] +int path +int up + +int nchars +int strlen() +% character*64 fstr + +begin + nchars = strlen (sppstr) + +% call f77pak (sppstr, fstr, 64) + call pwrzs (xval, yval, zval, fstr, nchars, CSIZE, path, up, 0) +end + + +# ?? + +procedure ie_draw_ticksx (x, y1, y2, zval, nvals) + +int nvals +real x[nvals] +real y1, y2 +real zval + +int i +real tkx[2], tky[2], dum + +begin + do i = 1, nvals { + call trn32s (x[i], y1, zval, tkx[1], tky[1], dum, 1) + call trn32s (x[i], y2, zval, tkx[2], tky[2], dum, 1) + call gpl (2, tkx[1], tky[1]) + } +end + + +# ?? + +procedure ie_draw_ticksy (x1, x2, y, zval, nvals) + +int nvals +real x1, x2 +real y[nvals] +real zval + +int i +real tkx[2], tky[2], dum + +begin + do i = 1, nvals { + call trn32s (x1, y[i], zval, tkx[1], tky[1], dum, 1) + call trn32s (x2, y[i], zval, tkx[2], tky[2], dum, 1) + call gpl (2, tkx[1], tky[1]) + } +end + + +# IE_SURF_LIMITS -- Apply the floor and ceiling constraints to the subraster. +# If either value is exactly zero, it is not applied. + +procedure ie_surf_limits (ras, m, floor, ceiling) + +real ras[m] +int m +real floor, ceiling +real val1_1 # value at ras[1] +int k +bool const_val # true if data are constant +bool bad_floor # true if no value is above floor +bool bad_ceiling # true if no value is below ceiling + +begin + const_val = true # initial values + bad_floor = true + bad_ceiling = true + val1_1 = ras[1] + + do k = 1, m + if (ras[k] != val1_1) { + const_val = false + break + } + if (!IS_INDEF(floor)) { + do k = 1, m { + if (ras[k] <= floor) + ras[k] = floor + else + bad_floor = false + } + } + if (!IS_INDEF(ceiling)) { + do k = 1, m { + if (ras[k] >= ceiling) + ras[k] = ceiling + else + bad_ceiling = false + } + } + + if (bad_floor && !IS_INDEF(floor)) + call error (1, "entire image is below (or at) specified floor") + if (bad_ceiling && !IS_INDEF(ceiling)) + call error (1, "entire image is above (or at) specified ceiling") + if (const_val) + call error (1, "all data values are the same; can't plot it") +end diff --git a/pkg/images/tv/imexamine/iestatistics.x b/pkg/images/tv/imexamine/iestatistics.x new file mode 100644 index 00000000..a3ac5f22 --- /dev/null +++ b/pkg/images/tv/imexamine/iestatistics.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "imexam.h" + + +# IE_STATISTICS -- Compute and print statistics. + +procedure ie_statistics (ie, x, y) + +pointer ie # IMEXAM structure +real x, y # Aperture coordinates + +double mean, median, std +int ncstat, nlstat, x1, x2,y1, y2, npts, clgeti() +pointer sp, imname, im, data, sortdata, ie_gimage(), ie_gdata() +string label "\ +# SECTION NPIX MEAN MEDIAN STDDEV MIN MAX\n" + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + ncstat = clgeti ("ncstat") + nlstat = clgeti ("nlstat") + x1 = x - (ncstat-1) / 2 + 0.5 + x2 = x + ncstat / 2 + 0.5 + y1 = y - (nlstat-1) / 2 + 0.5 + y2 = y + nlstat / 2 + 0.5 + iferr (data = ie_gdata (im, x1, x2, y1, y2)) { + call erract (EA_WARN) + return + } + npts = (x2-x1+1) * (y2-y1+1) + + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (sortdata, npts, TY_DOUBLE) + + call achtrd (Memr[data], Memd[sortdata], npts) + call asrtd (Memd[sortdata], Memd[sortdata], npts) + call aavgd (Memd[sortdata], npts, mean, std) + if (mod (npts, 2) == 0) + median = (Memd[sortdata+npts/2-1] + Memd[sortdata+npts/2]) / 2 + else + median = Memd[sortdata+npts/2] + + call sprintf (Memc[imname], SZ_FNAME, "[%d:%d,%d:%d]") + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + + if (IE_LASTKEY(ie) != 'm') + call printf (label) + + call printf ("%20s %8d %8.4g %8.4g %8.4g %8.4g %8.4g\n") + call pargstr (Memc[imname]) + call pargi (npts) + call pargd (mean) + call pargd (median) + call pargd (std) + call pargd (Memd[sortdata]) + call pargd (Memd[sortdata+npts-1]) + + if (IE_LOGFD(ie) != NULL) { + if (IE_LASTKEY(ie) != 'm') + call fprintf (IE_LOGFD(ie), label) + + call fprintf (IE_LOGFD(ie), + "%20s %8d %8.4g %8.4g %8.4g %8.4g %8.4g\n") + call pargstr (Memc[imname]) + call pargi (npts) + call pargd (mean) + call pargd (median) + call pargd (std) + call pargd (Memd[sortdata]) + call pargd (Memd[sortdata+npts-1]) + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ietimexam.x b/pkg/images/tv/imexamine/ietimexam.x new file mode 100644 index 00000000..869eaa4b --- /dev/null +++ b/pkg/images/tv/imexamine/ietimexam.x @@ -0,0 +1,121 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "imexam.h" + + +# IE_TIMEXAM -- Extract a subraster image. +# This routine does not currently update the WCS but it does clear it. + +procedure ie_timexam (ie, x, y) + +pointer ie # IE pointer +real x, y # Center + +int i, x1, x2, y1, y2, nx, ny +pointer sp, root, extn, output +pointer im, out, data, outbuf, mw + +int clgeti(), fnextn(), iki_validextn(), strlen(), imaccess() +pointer ie_gimage(), ie_gdata(), immap(), impl2r(), mw_open() +errchk impl2r + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + + # Get parameters. + call clgstr ("output", Memc[root], SZ_FNAME) + nx = clgeti ("ncoutput") + ny = clgeti ("nloutput") + + # Strip the extension. + call imgimage (Memc[root], Memc[root], SZ_FNAME) + if (Memc[root] == EOS) + call strcpy (IE_IMAGE(ie), Memc[root], SZ_FNAME) + i = fnextn (Memc[root], Memc[extn+1], SZ_FNAME) + Memc[extn] = EOS + if (i > 0) { + call iki_init() + if (iki_validextn (0, Memc[extn+1]) != 0) { + Memc[root+strlen(Memc[root])-i-1] = EOS + Memc[extn] = '.' + } + } + + do i = 1, ARB { + call sprintf (Memc[output], SZ_FNAME, "%s.%03d%s") + call pargstr (Memc[root]) + call pargi (i) + call pargstr (Memc[extn]) + if (imaccess (Memc[output], 0) == NO) + break + } + + # Set section to be extracted. + if (!IS_INDEF(x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 + x2 = IE_X1(ie) + nx / 2 + 0.5 + y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 + y2 = IE_Y1(ie) + ny / 2 + 0.5 + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # Set output. + iferr (out = immap (Memc[output], NEW_COPY, im)) { + call erract (EA_WARN) + return + } + IM_NDIM(out) = 2 + IM_LEN(out,1) = nx + IM_LEN(out,2) = ny + + # Extract the section. + iferr { + do i = y1, y2 { + data = ie_gdata (im, x1, x2, i, i) + outbuf = impl2r (out, i-y1+1) + call amovr (Memr[data], Memr[outbuf], nx) + } + mw = mw_open (NULL, 2) + call mw_saveim (mw, out) + call imunmap (out) + } then { + call imunmap (out) + iferr (call imdelete (Memc[output])) + ; + call sfree (sp) + call erract (EA_WARN) + return + } + + call printf ("%s[%d:%d,%d:%d] -> %s\n") + call pargstr (IE_IMAGE(ie)) + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + call pargstr (Memc[output]) + if (IE_LOGFD(ie) != NULL) { + call fprintf (IE_LOGFD(ie), "%s[%d:%d,%d:%d] -> %s\n") + call pargstr (IE_IMAGE(ie)) + call pargi (x1) + call pargi (x2) + call pargi (y1) + call pargi (y2) + } + + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/ievimexam.x b/pkg/images/tv/imexamine/ievimexam.x new file mode 100644 index 00000000..a75ac2bc --- /dev/null +++ b/pkg/images/tv/imexamine/ievimexam.x @@ -0,0 +1,582 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "imexam.h" + +define BTYPES "|constant|nearest|reflect|wrap|project|" +define SZ_BTYPE 8 # Length of boundary type string +define NLINES 16 # Number of image lines in the buffer + + +# IE_VIMEXAM -- Plot the vector of image data between two pixels. +# There are two types of plot selected by the key argument. The +# second cursor position is passed in the IMEXAM data structure. +# The first position is either the middle of the vector or the starting +# point. + +procedure ie_vimexam (gp, mode, ie, x, y, key) + +pointer gp # GIO pointer +int mode # Graph mode +pointer ie # IMEXAM pointer +real x, y # Starting or center coordinate +int key # 'u' centered vector, 'v' two endpoint vector + +int btype, nxvals, nyvals, nzvals, width +pointer sp, title, boundary, im, x_vec, y_vec, pp +real x1, y1, x2, y2, zmin, zmax, bconstant + +bool fp_equalr() +int clgpseti(), clgwrd(), clopset() +real clgpsetr() +pointer ie_gimage() +errchk malloc + +begin + iferr (im = ie_gimage (ie, NO)) { + call erract (EA_WARN) + return + } + + call smark (sp) + call salloc (title, IE_SZTITLE, TY_CHAR) + call salloc (boundary, SZ_BTYPE, TY_CHAR) + + # Get boundary extension parameters. + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + IE_PP(ie) = clopset ("vimexam") + pp = IE_PP(ie) + btype = clgwrd ("vimexam.boundary", Memc[boundary], SZ_BTYPE, BTYPES) + bconstant = clgpsetr (pp, "constant") + + nxvals = IM_LEN(im,1) + nyvals = IM_LEN(im,2) + + if (!IS_INDEF (x)) + IE_X1(ie) = x + if (!IS_INDEF(y)) + IE_Y1(ie) = y + + x1 = IE_X1(ie) + x2 = IE_X2(ie) + y1 = IE_Y1(ie) + y2 = IE_Y2(ie) + width = clgpseti (pp, "naverage") + + # Check the boundary and compute the length of the output vector. + x1 = max (1.0, min (x1, real (nxvals))) + x2 = min (real(nxvals), max (1.0, x2)) + y1 = max (1.0, min (y1, real (nyvals))) + y2 = min (real(nyvals), max (1.0, y2)) + nzvals = int (sqrt ((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1))) + 1 + + # Check for cases which should be handled by pcols or prows. + call malloc (x_vec, nzvals, TY_REAL) + call malloc (y_vec, nzvals, TY_REAL) + if (fp_equalr (x1, x2)) + call ie_get_col (im, x1, y1, x2, y2, nzvals, width, btype, + bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) + else if (fp_equalr (y1, y2)) + call ie_get_row (im, x1, y1, x2, y2, nzvals, width, btype, + bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) + else + call ie_get_vector (im, x1, y1, x2, y2, nzvals, width, btype, + bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) + + # Convert endpoint plot coordinates to centered coordinates. + if (key == 'u') { + zmin = (IE_X1(ie) + IE_X2(ie)) / 2 + zmax = (IE_Y1(ie) + IE_Y2(ie)) / 2 + zmin = sqrt ((zmin-x1)**2 + (zmax-y1)**2) + call asubkr (Memr[x_vec], zmin, Memr[x_vec], nzvals) + } + + call sprintf (Memc[title], IE_SZTITLE, + "%s: Vector %.1f,%.1f to %.1f,%.1f naverage: %d\n%s") + call pargstr (IE_IMNAME(ie)) + call pargr (x1) + call pargr (y1) + call pargr (x2) + call pargr (y2) + call pargi (width) + call pargstr (IM_TITLE(im)) + + call ie_graph (gp, mode, pp, Memc[title], Memr[x_vec], Memr[y_vec], + nzvals, "", "") + + # Finish up + call mfree (x_vec, TY_REAL) + call mfree (y_vec, TY_REAL) + call sfree (sp) +end + + +# IE_GET_VECTOR -- Average a strip perpendicular to a given vector and return +# vectors of point number and average pixel value. Also returned is the min +# and max value in the data vector. + +procedure ie_get_vector (im, x1, y1, x2, y2, nvals, width, btype, + bconstant, x_vector, y_vector, zmin, zmax) + +pointer im # pointer to image header +real x1, y1 # starting pixel of vector +real x2, y2 # ending pixel of pixel +real bconstant # Boundary extension constant +int btype # Boundary extension type +int nvals # number of samples along the vector +int width # width of strip to average over +real x_vector[ARB] # Pixel numbers +real y_vector[ARB] # Average pixel values (returned) +real zmin, zmax # min, max of data vector + +double dx, dy, dpx, dpy, ratio, xoff, yoff, noff, xv, yv +int i, j, k, nedge, col1, col2, line1, line2 +int colb, colc, line, linea, lineb, linec +pointer sp, oxs, oys, xs, ys, yvals, msi, buf +real sum , lim1, lim2, lim3, lim4 +pointer imgs2r() +errchk msiinit + +begin + call smark (sp) + call salloc (oxs, width, TY_REAL) + call salloc (oys, width, TY_REAL) + call salloc (xs, width, TY_REAL) + call salloc (ys, width, TY_REAL) + call salloc (yvals, width, TY_REAL) + + # Determine sampling perpendicular to vector. + dx = (x2 - x1) / (nvals - 1) + dy = (y2 - y1) / (nvals - 1) + if (x1 < x2) { + dpx = -dy + dpy = dx + } else { + dpx = dy + dpy = -dx + } + + # Compute offset from the nominal vector to the first sample point. + ratio = dx / dy + nedge = width + 1 + noff = (real (width) - 1.0) / 2.0 + xoff = noff * dpx + yoff = noff * dpy + + # Initialize the interpolator and the image data buffer. + call msiinit (msi, II_BILINEAR) + buf = NULL + + # Set the boundary. + col1 = int (min (x1, x2)) - nedge + col2 = nint (max (x1, x2)) + nedge + line1 = int (min (y1, y2)) - nedge + line2 = nint (max (y2, y1)) + nedge + call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) + + # Initialize. + xv = x1 - xoff + yv = y1 - yoff + do j = 1, width { + Memr[oxs+j-1] = double (j - 1) * dpx + Memr[oys+j-1] = double (j - 1) * dpy + } + + # Loop over the output image lines. + do i = 1, nvals { + x_vector[i] = real (i) + line = yv + + # Get the input image data and fit an interpolator to the data. + # The input data is buffered in a section of size NLINES + 2 * + # NEDGE. + + if (dy >= 0.0 && (buf == NULL || line > (linea))) { + linea = min (line2, line + NLINES - 1) + lineb = max (line1, line - nedge) + linec = min (line2, linea + nedge) + lim1 = xv + lim2 = lim1 + double (width - 1) * dpx + lim3 = xv + double (linea - line + 1) * ratio + lim4 = lim3 + double (width - 1) * dpx + colb = max (col1, int (min (lim1, lim2, lim3, lim4)) - 1) + colc = min (col2, nint (max (lim1, lim2, lim3, lim4)) + 1) + buf = imgs2r (im, colb, colc, lineb, linec) + call msifit (msi, Memr[buf], colc - colb + 1, linec - lineb + + 1, colc - colb + 1) + + } else if (dy < 0.0 && (buf == NULL || line < linea)) { + linea = max (line1, line - NLINES + 1) + lineb = max (line1, linea - nedge) + linec = min (line2, line + nedge) + lim1 = xv + lim2 = lim1 + double (width - 1) * dpx + lim3 = xv + double (linea - line - 1) * ratio + lim4 = lim3 + double (width - 1) * dpx + colb = max (col1, int (min (lim1, lim2, lim3, lim4)) - 1) + colc = min (col2, nint (max (lim1, lim2, lim3, lim4)) + 1) + buf = imgs2r (im, colb, colc, lineb, linec) + call msifit (msi, Memr[buf], colc - colb + 1, linec - lineb + + 1, colc - colb + 1) + } + + # Evaluate the interpolant. + call aaddkr (Memr[oxs], real (xv - colb + 1), Memr[xs], width) + call aaddkr (Memr[oys], real (yv - lineb + 1), Memr[ys], width) + call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], width) + + if (width == 1) + y_vector[i] = Memr[yvals] + else { + sum = 0.0 + do k = 1, width + sum = sum + Memr[yvals+k-1] + y_vector[i] = sum / width + } + + xv = xv + dx + yv = yv + dy + } + + # Compute min and max values. + call alimr (y_vector, nvals, zmin, zmax) + + # Free memory . + call msifree (msi) + call sfree (sp) +end + + +# IE_GET_COL -- Average a strip perpendicular to a column vector and return +# vectors of point number and average pixel value. Also returned is the min +# and max value in the data vector. + +procedure ie_get_col (im, x1, y1, x2, y2, nvals, width, btype, + bconstant, x_vector, y_vector, zmin, zmax) + +pointer im # pointer to image header +real x1, y1 # starting pixel of vector +real x2, y2 # ending pixel of pixel +int nvals # number of samples along the vector +int width # width of strip to average over +int btype # Boundary extension type +real bconstant # Boundary extension constant +real x_vector[ARB] # Pixel numbers +real y_vector[ARB] # Average pixel values (returned) +real zmin, zmax # min, max of data vector + +real sum +int line, linea, lineb, linec +pointer sp, xs, ys, msi, yvals, buf +double dx, dy, xoff, noff, xv, yv +int i, j, k, nedge, col1, col2, line1, line2 +pointer imgs2r() +errchk msiinit + +begin + call smark (sp) + call salloc (xs, width, TY_REAL) + call salloc (ys, width, TY_REAL) + call salloc (yvals, width, TY_REAL) + + # Initialize the interpolator and the image data buffer. + call msiinit (msi, II_BILINEAR) + buf = NULL + + # Set the boundary. + nedge = max (2, width / 2 + 1) + col1 = int (x1) - nedge + col2 = nint (x1) + nedge + line1 = int (min (y1, y2)) - nedge + line2 = nint (max (y1, y2)) + nedge + call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) + + # Determine sampling perpendicular to vector. + dx = 1.0d0 + if (nvals == 1) + dy = 0.0d0 + else + dy = (y2 - y1) / (nvals - 1) + + # Compute offset from the nominal vector to the first sample point. + noff = (real (width) - 1.0) / 2.0 + xoff = noff * dx + xv = x1 - xoff + do j = 1, width + Memr[xs+j-1] = xv + double (j - col1) + yv = y1 + + # Loop over the output image lines. + do i = 1, nvals { + x_vector[i] = real (i) + line = yv + + # Get the input image data and fit an interpolator to the data. + # The input data is buffered in a section of size NLINES + 2 * + # NEDGE. + + if (dy >= 0.0 && (buf == NULL || line > (linea))) { + linea = min (line2, line + NLINES - 1) + lineb = max (line1, line - nedge) + linec = min (line2, linea + nedge) + buf = imgs2r (im, col1, col2, lineb, linec) + call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + + 1, col2 - col1 + 1) + } else if (dy < 0.0 && (buf == NULL || line < linea)) { + linea = max (line1, line - NLINES + 1) + lineb = max (line1, linea - nedge) + linec = min (line2, line + nedge) + buf = imgs2r (im, col1, col2, lineb, linec) + call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + + 1, col2 - col1 + 1) + } + + # Evaluate the interpolant. + call amovkr (real (yv - lineb + 1), Memr[ys], width) + call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], width) + + if (width == 1) + y_vector[i] = Memr[yvals] + else { + sum = 0.0 + do k = 1, width + sum = sum + Memr[yvals+k-1] + y_vector[i] = sum / width + } + + yv = yv + dy + } + + # Compute min and max values. + call alimr (y_vector, nvals, zmin, zmax) + + # Free memory . + call msifree (msi) + call sfree (sp) +end + + +# IE_GET_ROW -- Average a strip parallel to a row vector and return +# vectors of point number and average pixel value. Also returned is the min +# and max value in the data vector. + +procedure ie_get_row (im, x1, y1, x2, y2, nvals, width, btype, bconstant, + x_vector, y_vector, zmin, zmax) + +pointer im # pointer to image header +real x1, y1 # starting pixel of vector +real x2, y2 # ending pixel of pixel +int nvals # number of samples along the vector +int width # width of strip to average over +int btype # Boundary extension type +real bconstant # Boundary extension constant +real x_vector[ARB] # Pixel numbers +real y_vector[ARB] # Average pixel values (returned) +real zmin, zmax # min, max of data vector + +double dx, dy, yoff, noff, xv, yv +int i, j, nedge, col1, col2, line1, line2 +int line, linea, lineb, linec +pointer sp, oys, xs, ys, yvals, msi, buf +errchk imgs2r, msifit, msiinit +pointer imgs2r() + +begin + call smark (sp) + call salloc (oys, width, TY_REAL) + call salloc (xs, nvals, TY_REAL) + call salloc (ys, nvals, TY_REAL) + call salloc (yvals, nvals, TY_REAL) + + # Initialize the interpolator and the image data buffer. + call msiinit (msi, II_BILINEAR) + buf = NULL + + # Set the boundary. + nedge = max (2, width / 2 + 1) + col1 = int (min (x1, x2)) - nedge + col2 = nint (max (x1, x2)) + nedge + line1 = int (y1) - nedge + line2 = nint (y1) + nedge + call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) + + # Determine sampling perpendicular to vector. + if (nvals == 1) + dx = 0.0d0 + else + dx = (x2 - x1) / (nvals - 1) + dy = 1.0 + + # Compute offset from the nominal vector to the first sample point. + noff = (real (width) - 1.0) / 2.0 + xv = x1 - col1 + 1 + do i = 1, nvals { + Memr[xs+i-1] = xv + xv = xv + dx + } + yoff = noff * dy + yv = y1 - yoff + do j = 1, width + Memr[oys+j-1] = yv + double (j - 1) + + # Clear the accululator. + call aclrr (y_vector, nvals) + + # Loop over the output image lines. + do i = 1, width { + line = yv + + # Get the input image data and fit an interpolator to the data. + # The input data is buffered in a section of size NLINES + 2 * + # NEDGE. + + if (dy >= 0.0 && (buf == NULL || line > (linea))) { + linea = min (line2, line + NLINES - 1) + lineb = max (line1, line - nedge) + linec = min (line2, linea + nedge) + buf = imgs2r (im, col1, col2, lineb, linec) + if (buf == NULL) + call error (0, "Error reading input image.") + call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + + 1, col2 - col1 + 1) + } else if (dy < 0.0 && (buf == NULL || line < linea)) { + linea = max (line1, line - NLINES + 1) + lineb = max (line1, linea - nedge) + linec = min (line2, line + nedge) + buf = imgs2r (im, col1, col2, lineb, linec) + if (buf == NULL) + call error (0, "Error reading input image.") + call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + + 1, col2 - col1 + 1) + } + + # Evaluate the interpolant. + call amovkr (real (Memr[oys+i-1] - lineb + 1), Memr[ys], nvals) + call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], nvals) + + if (width == 1) + call amovr (Memr[yvals], y_vector, nvals) + else + call aaddr (Memr[yvals], y_vector, y_vector, nvals) + + yv = yv + dy + } + + # Compute the x and y vectors. + do i = 1, nvals + x_vector[i] = real (i) + if (width > 1) + call adivkr (y_vector, real (width), y_vector, nvals) + + # Compute min and max values. + call alimr (y_vector, nvals, zmin, zmax) + + # Free memory . + call msifree (msi) + call sfree (sp) +end + + +# IE_SETBOUNDARY -- Set boundary extension. + +procedure ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) + +pointer im # IMIO pointer +int col1, col2 # Range of columns +int line1, line2 # Range of lines +int btype # Boundary extension type +real bconstant # Constant for constant boundary extension + +int btypes[5] +int nbndrypix +data btypes /BT_CONSTANT, BT_NEAREST, BT_REFLECT, BT_WRAP, BT_PROJECT/ + +begin + nbndrypix = 0 + nbndrypix = max (nbndrypix, 1 - col1) + nbndrypix = max (nbndrypix, col2 - IM_LEN(im, 1)) + nbndrypix = max (nbndrypix, 1 - line1) + nbndrypix = max (nbndrypix, line2 - IM_LEN(im, 2)) + + call imseti (im, IM_TYBNDRY, btypes[btype]) + call imseti (im, IM_NBNDRYPIX, nbndrypix + 1) + if (btypes[btype] == BT_CONSTANT) + call imsetr (im, IM_BNDRYPIXVAL, bconstant) +end + + +# IE_BUFL2R -- Maintain buffer of image lines. A new buffer is created when +# the buffer pointer is null or if the number of lines requested is changed. +# The minimum number of image reads is used. + +procedure ie_bufl2r (im, col1, col2, line1, line2, buf) + +pointer im # Image pointer +int col1 # First image column of buffer +int col2 # Last image column of buffer +int line1 # First image line of buffer +int line2 # Last image line of buffer +pointer buf # Buffer + +pointer buf1, buf2 +int i, ncols, nlines, nclast, llast1, llast2, nllast +errchk malloc, realloc, imgs2r +pointer imgs2r() + +begin + ncols = col2 - col1 + 1 + nlines = line2 - line1 + 1 + + # If the buffer pointer is undefined then allocate memory for the + # buffer. If the number of columns or lines requested changes + # reallocate the buffer. Initialize the last line values to force + # a full buffer image read. + + if (buf == NULL) { + call malloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } else if ((nlines != nllast) || (ncols != nclast)) { + call realloc (buf, ncols * nlines, TY_REAL) + llast1 = line1 - nlines + llast2 = line2 - nlines + } + + # Read only the image lines with are different from the last buffer. + + if (line1 < llast1) { + do i = line2, line1, -1 { + if (i > llast1) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } else if (line2 > llast2) { + do i = line1, line2 { + if (i < llast2) + buf1 = buf + (i - llast1) * ncols + else + buf1 = imgs2r (im, col1, col2, i, i) + + buf2 = buf + (i - line1) * ncols + call amovr (Memr[buf1], Memr[buf2], ncols) + } + } + + # Save the buffer parameters. + + llast1 = line1 + llast2 = line2 + nclast = ncols + nllast = nlines +end diff --git a/pkg/images/tv/imexamine/imexam.h b/pkg/images/tv/imexamine/imexam.h new file mode 100644 index 00000000..f1fe00d8 --- /dev/null +++ b/pkg/images/tv/imexamine/imexam.h @@ -0,0 +1,55 @@ +# IMEXAM.H -- IMEXAMINE global definitions. + +define MAX_FRAMES 16 # max display frames + +# IMEXAMINE data structure. + +define IE_LEN 370 # length of IE structure +define IE_SZFNAME 99 # length of file name +define IE_SZFORMAT 9 # length of format strings +define IE_SZTITLE 512 # length of multiline title + +define IE_IM Memi[$1] # IMIO pointer +define IE_MW Memi[$1+1] # MWCS pointer +define IE_CTLW Memi[$1+2] # CT-MWCS pointer (L -> W) +define IE_CTWL Memi[$1+3] # CT-MWCS pointer (W -> L) +define IE_DS Memi[$1+4] # display frame pointer +define IE_GP Memi[$1+5] # GIO pointer +define IE_PP Memi[$1+6] # pset pointer +define IE_LIST Memi[$1+7] # image list +define IE_LISTLEN Memi[$1+8] # number of images in list +define IE_USEDISPLAY Memi[$1+9] # use image display? +define IE_INDEX Memi[$1+10] # image index +define IE_DFRAME Memi[$1+11] # frame used to display images +define IE_MAPFRAME Memi[$1+12] # mapped display frame +define IE_NEWFRAME Memi[$1+13] # new (current) display frame +define IE_NFRAMES Memi[$1+14] # number of image frames +define IE_ALLFRAMES Memi[$1+15] # use all frames for display? +define IE_LOGFD Memi[$1+16] # log file descriptor +define IE_MAGZERO Memr[P2R($1+17)] # magnitude zero point +define IE_XORIGIN Memr[P2R($1+18)] # X origin +define IE_YORIGIN Memr[P2R($1+19)] # Y origin +define IE_GTYPE Memi[$1+20] # current graph type +define IE_X1 Memr[P2R($1+21)] # current graph x1 +define IE_X2 Memr[P2R($1+22)] # current graph x2 +define IE_Y1 Memr[P2R($1+23)] # current graph y1 +define IE_Y2 Memr[P2R($1+24)] # current graph y2 +define IE_IX1 Memi[$1+25] # image section coordinate +define IE_IX2 Memi[$1+26] # image section coordinate +define IE_IY1 Memi[$1+27] # image section coordinate +define IE_IY2 Memi[$1+28] # image section coordinate +define IE_P1 Memi[$1+29] # Physical axis for logical x +define IE_P2 Memi[$1+30] # Physical axis for logical y +define IE_IN Memr[P2R($1+31)+$2-1] # Input coordinate vector +define IE_OUT Memr[P2R($1+38)+$2-1] # Output coordinate vector +define IE_WCSDIM Memi[$1+45] # WCS dimension +define IE_LASTKEY Memi[$1+46] # last type of keyed output + # (available) +define IE_IMAGE Memc[P2C($1+50)] # full image name +define IE_IMNAME Memc[P2C($1+100)] # short image name for labels +define IE_LOGFILE Memc[P2C($1+150)] # logfile name +define IE_WCSNAME Memc[P2C($1+200)] # WCS name +define IE_XLABEL Memc[P2C($1+250)] # WCS label +define IE_YLABEL Memc[P2C($1+300)] # WCS label +define IE_XFORMAT Memc[P2C($1+350)] # WCS format +define IE_YFORMAT Memc[P2C($1+360)] # WCS format diff --git a/pkg/images/tv/imexamine/imexamine.par b/pkg/images/tv/imexamine/imexamine.par new file mode 100644 index 00000000..fc409b45 --- /dev/null +++ b/pkg/images/tv/imexamine/imexamine.par @@ -0,0 +1,22 @@ +input,s,a,,,,images to be examined +output,s,h,"",,,output root image name +ncoutput,i,h,101,1,,Number of columns in image output +nloutput,i,h,101,1,,Number of lines in image output +frame,i,q,1,1,,display frame +image,s,q,,,,image name +logfile,s,h,"",,,logfile +keeplog,b,h,no,,,log output results +defkey,s,h,"a",,,default key for cursor list input +autoredraw,b,h,yes,,,automatically redraw graph +allframes,b,h,yes,,,use all frames for displaying new images +nframes,i,h,0,,,number of display frames (0 to autosense) +ncstat,i,h,5,1,,number of columns for statistics +nlstat,i,h,5,1,,number of lines for statistics +graphcur,*gcur,h,"",,,graphics cursor input +imagecur,*imcur,h,"",,,image display cursor input +wcs,s,h,"logical",,,Coordinate system +xformat,s,h,"",,,X axis coordinate format +yformat,s,h,"",,,Y axis coordinate format +graphics,s,h,"stdgraph",,,graphics device +display,s,h,"display(image='$1',frame=$2)",,,display command template +use_display,b,h,yes,,,enable direct display interaction diff --git a/pkg/images/tv/imexamine/mkpkg b/pkg/images/tv/imexamine/mkpkg new file mode 100644 index 00000000..38c3fef7 --- /dev/null +++ b/pkg/images/tv/imexamine/mkpkg @@ -0,0 +1,48 @@ +# IMEXAMINE + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +standalone: + $set LIBS1 = "-lds -liminterp -lncar -lgks -lxtools" + $set LIBS2 = "-lgsurfit -lnlfit -lcurfit -lllsq" + $update libpkg.a + $omake x_imexam.x + $link x_imexam.o libpkg.a $(LIBS1) $(LIBS2) -o xx_imexam.e + ; + +libpkg.a: + iecimexam.x imexam.h + iecolon.x imexam.h + iedisplay.x + ieeimexam.x imexam.h \ + + iegcur.x imexam.h + iegdata.x + iegimage.x imexam.h + iegnfr.x imexam.h + iegraph.x imexam.h + iehimexam.x imexam.h + ieimname.x + iejimexam.x imexam.h + ielimexam.x imexam.h + iemw.x imexam.h + ieopenlog.x imexam.h + iepos.x imexam.h + ieprint.x imexam.h + ieqrimexam.x imexam.h \ + + ierimexam.x imexam.h \ + + iesimexam.x imexam.h + iestatistics.x imexam.h + ietimexam.x imexam.h + ievimexam.x imexam.h \ + + stfmeasure.x starfocus.h + stfprofile.x starfocus.h \ + + t_imexam.x imexam.h + ; diff --git a/pkg/images/tv/imexamine/starfocus.h b/pkg/images/tv/imexamine/starfocus.h new file mode 100644 index 00000000..cf397e50 --- /dev/null +++ b/pkg/images/tv/imexamine/starfocus.h @@ -0,0 +1,140 @@ +# STARFOCUS + +# Types of coordinates +define SF_TYPES "|center|mark1|markall|" +define SF_CENTER 1 # Star at center of image +define SF_MARK1 2 # Mark stars in first image +define SF_MARKALL 3 # Mark stars in all images + +# Task type +define STARFOCUS 1 +define PSFMEASURE 2 + +# Radius types +define SF_WTYPES "|Radius|FWHM|GFWHM|MFWHM|" + +define SF_RMIN 16 # Minimum centering search radius +define MAX_FRAMES 8 # Maximum number of display frames + +# Data structures for STARFOCUS + +define NBNDRYPIX 0 # Number of boundary pixels +define TYBNDRY BT_REFLECT # Type of boundary extension +define SAMPLE .2 # Subpixel sampling size +define SF_SZFNAME 79 # Length of file names +define SF_SZWTYPE 7 # Length of width type string + +# Main data structure +define SF 40 +define SF_TASK Memi[$1] # Task type +define SF_WTYPE Memc[P2C($1+1)] # Width type string +define SF_WCODE Memi[$1+5] # Width code +define SF_BETA Memr[P2R($1+6)] # Moffat beta +define SF_SCALE Memr[P2R($1+7)] # Pixel scale +define SF_LEVEL Memr[P2R($1+8)] # Profile measurement level +define SF_RADIUS Memr[P2R($1+9)] # Profile radius +define SF_SBUF Memr[P2R($1+10)] # Sky region buffer +define SF_SWIDTH Memr[P2R($1+11)] # Sky region width +define SF_SAT Memr[P2R($1+12)] # Saturation +define SF_NIT Memi[$1+13] # Number of iterations for radius +define SF_OVRPLT Memi[$1+14] # Overplot the best profile? +define SF_NCOLS Memi[$1+15] # Number of image columns +define SF_NLINES Memi[$1+16] # Number of image lines +define SF_XF Memr[P2R($1+17)] # X field center +define SF_YF Memr[P2R($1+18)] # Y field center +define SF_GP Memi[$1+19] # GIO pointer +define SF_F Memr[P2R($1+20)] # Best focus +define SF_W Memr[P2R($1+21)] # Width at best focus +define SF_M Memr[P2R($1+22)] # Brightest star magnitude +define SF_XP1 Memr[P2R($1+23)] # First derivative point to plot +define SF_XP2 Memr[P2R($1+24)] # Last derivative point to plot +define SF_YP1 Memr[P2R($1+25)] # Minimum of derivative profile +define SF_YP2 Memr[P2R($1+26)] # Maximum of derivative profile +define SF_N Memi[$1+27] # Number of points not deleted +define SF_NSFD Memi[$1+28] # Number of data points +define SF_SFDS Memi[$1+29] # Pointer to data structures +define SF_NS Memi[$1+30] # Number of stars not deleted +define SF_NSTARS Memi[$1+31] # Number of stars +define SF_STARS Memi[$1+32] # Pointer to star groups +define SF_NF Memi[$1+33] # Number of focuses not deleted +define SF_NFOCUS Memi[$1+34] # Number of different focus values +define SF_FOCUS Memi[$1+35] # Pointer to focus groups +define SF_NI Memi[$1+36] # Number of images not deleted +define SF_NIMAGES Memi[$1+37] # Number of images +define SF_IMAGES Memi[$1+38] # Pointer to image groups +define SF_BEST Memi[$1+39] # Pointer to best focus star + +define SF_SFD Memi[SF_SFDS($1)+$2-1] +define SF_SFS Memi[SF_STARS($1)+$2-1] +define SF_SFF Memi[SF_FOCUS($1)+$2-1] +define SF_SFI Memi[SF_IMAGES($1)+$2-1] + +# Basic data structure. +define SFD 94 +define SFD_IMAGE Memc[P2C($1)] # Image name +define SFD_DATA Memi[$1+40] # Pointer to real image raster +define SFD_RADIUS Memr[P2R($1+41)] # Profile radius +define SFD_NP Memi[$1+42] # Number of profile points +define SFD_NPMAX Memi[$1+43] # Maximum number of profile points +define SFD_X1 Memi[$1+44] # Image raster limits +define SFD_X2 Memi[$1+45] +define SFD_Y1 Memi[$1+46] +define SFD_Y2 Memi[$1+47] +define SFD_ID Memi[$1+48] # Star ID +define SFD_X Memr[P2R($1+49)] # Star X position +define SFD_Y Memr[P2R($1+50)] # Star Y position +define SFD_F Memr[P2R($1+51)] # Focus +define SFD_W Memr[P2R($1+52)] # Width to use +define SFD_M Memr[P2R($1+53)] # Magnitude +define SFD_E Memr[P2R($1+54)] # Ellipticity +define SFD_PA Memr[P2R($1+55)] # Position angle +define SFD_R Memr[P2R($1+56)] # Radius at given level +define SFD_DFWHM Memr[P2R($1+57)] # Direct FWHM +define SFD_GFWHM Memr[P2R($1+58)] # Gaussian FWHM +define SFD_MFWHM Memr[P2R($1+59)] # Moffat FWHM +define SFD_ASI1 Memi[$1+60] # Pointer to enclosed flux profile +define SFD_ASI2 Memi[$1+61] # Pointer to derivative profile +define SFD_YP1 Memr[P2R($1+62)] # Minimum of derivative profile +define SFD_YP2 Memr[P2R($1+63)] # Maximum of derivative profile +define SFD_FWHM Memr[P2R($1+$2+63)] # FWHM vs level=0.5*i (i=1-19) +define SFD_BKGD Memr[P2R($1+83)] # Background value +define SFD_BKGD1 Memr[P2R($1+84)] # Original background value +define SFD_MISO Memr[P2R($1+85)] # Moment isophote +define SFD_SIGMA Memr[P2R($1+86)] # Moffat alpha +define SFD_ALPHA Memr[P2R($1+87)] # Moffat alpha +define SFD_BETA Memr[P2R($1+88)] # Moffat beta +define SFD_STATUS Memi[$1+89] # Status +define SFD_NSAT Memi[$1+90] # Number of saturated pixels +define SFD_SFS Memi[$1+91] # Pointer to star group +define SFD_SFF Memi[$1+92] # Pointer to focus group +define SFD_SFI Memi[$1+93] # Pointer to image group + + +# Structure grouping data by star. +define SFS ($1+7) +define SFS_ID Memi[$1] # Star ID +define SFS_F Memr[P2R($1+1)] # Best focus +define SFS_W Memr[P2R($1+2)] # Best width +define SFS_M Memr[P2R($1+3)] # Average magnitude +define SFS_N Memi[$1+4] # Number of points used +define SFS_NF Memi[$1+5] # Number of focuses +define SFS_NSFD Memi[$1+6] # Number of data points +define SFS_SFD Memi[$1+$2+6] # Array of data structures + + +# Structure grouping stars by focus values. +define SFF ($1+5) +define SFF_F Memr[P2R($1)] # Focus +define SFF_W Memr[P2R($1+1)] # Average width +define SFF_N Memi[$1+2] # Number in average +define SFF_NI Memi[$1+3] # Number of images +define SFF_NSFD Memi[$1+4] # Number of data points +define SFF_SFD Memi[$1+$2+4] # Array of data structures + + +# Structure grouping stars by image. +define SFI ($1+42) +define SFI_IMAGE Memc[P2C($1)] # Image +define SFI_N Memi[$1+40] # Number in imagE +define SFI_NSFD Memi[$1+41] # Number of data points +define SFI_SFD Memi[$1+$2+41] # Array of data structures diff --git a/pkg/images/tv/imexamine/stfmeasure.x b/pkg/images/tv/imexamine/stfmeasure.x new file mode 100644 index 00000000..7390bf1c --- /dev/null +++ b/pkg/images/tv/imexamine/stfmeasure.x @@ -0,0 +1,147 @@ +include +include +include +include +include "starfocus.h" + + +# STF_MEASURE -- PSF measuring routine. +# This is a stand-alone routine that can be called to return the FWHM. +# It is a greatly abbreviated version of starfocus. + +procedure stf_measure (im, xc, yc, beta, level, radius, nit, + sbuffer, swidth, saturation, gp, logfd, + bkg, renclosed, dfwhm, gfwhm, mfwhm) + +pointer im #I Image pointer +real xc #I Initial X center +real yc #I Initial Y center +real beta #I Moffat beta +real level #I Measurement level +real radius #U Profile radius +int nit #I Number of iterations on radius +real sbuffer #I Sky buffer (pixels) +real swidth #I Sky width (pixels) +real saturation #I Saturation +pointer gp #I Graphics output if not NULL +int logfd #I Log output if not NULL +real bkg #O Background used +real renclosed #O Enclosed flux radius +real dfwhm #O Direct FWHM +real gfwhm #O Gaussian FWHM +real mfwhm #O Moffat FWHM + +int i +bool ignore_sat +pointer sp, str, sf, sfd, sfds + +int strdic() +real stf_r2i() +errchk stf_find, stf_bkgd, stf_profile, stf_widths, stf_fwhms, stf_organize + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + call salloc (sf, SF, TY_STRUCT) + call salloc (sfd, SFD, TY_STRUCT) + call salloc (sfds, 1, TY_POINTER) + call aclri (Memi[sf], SF) + call aclri (Memi[sfd], SFD) + Memi[sfds] = sfd + + # Initialize parameters. + SF_TASK(sf) = PSFMEASURE + SF_WCODE(sf) = strdic ("FWHM", SF_WTYPE(sf), SF_SZWTYPE, SF_WTYPES) + SF_SCALE(sf) = 1. + SF_LEVEL(sf) = level + SF_BETA(sf) = beta + SF_RADIUS(sf) = radius + SF_SBUF(sf) = sbuffer + SF_SWIDTH(sf) = swidth + SF_SAT(sf) = saturation + SF_NIT(sf) = nit + SF_OVRPLT(sf) = NO + SF_NCOLS(sf) = IM_LEN(im,1) + SF_NLINES(sf) = IM_LEN(im,2) + SF_XF(sf) = (IM_LEN(im,1) + 1) / 2. + SF_YF(sf) = (IM_LEN(im,2) + 1) / 2. + ignore_sat = false + + call imstats (im, IM_IMAGENAME, SFD_IMAGE(sfd), SF_SZFNAME) + SFD_ID(sfd) = 1 + SFD_X(sfd) = xc + SFD_Y(sfd) = yc + SFD_F(sfd) = INDEF + SFD_STATUS(sfd) = 0 + SFD_SFS(sfd) = NULL + SFD_SFF(sfd) = NULL + SFD_SFI(sfd) = NULL + + if (SF_LEVEL(sf) > 1.) + SF_LEVEL(sf) = SF_LEVEL(sf) / 100. + SF_LEVEL(sf) = max (0.05, min (0.95, SF_LEVEL(sf))) + + # Evaluate PSF data. + iferr { + do i = 1, SF_NIT(sf) { + if (i == 1) + SFD_RADIUS(sfd) = SF_RADIUS(sf) + else + SFD_RADIUS(sfd) = 3. * SFD_DFWHM(sfd) + SFD_NPMAX(sfd) = stf_r2i (SFD_RADIUS(sfd)) + 1 + SFD_NP(sfd) = SFD_NPMAX(sfd) + call stf_find (sf, sfd, im) + call stf_bkgd (sf, sfd) + if (SFD_NSAT(sfd) > 0 && i == 1) { + if (ignore_sat) + call error (0, + "Saturated pixels found - ignoring object") + else + call eprintf ( + "WARNING: Saturated pixels found.\n") + } + call stf_profile (sf, sfd) + call stf_widths (sf, sfd) + call stf_fwhms (sf, sfd) + } + + # Set output results. + radius = SFD_RADIUS(sfd) + bkg = SFD_BKGD(sfd) + renclosed = SFD_R(sfd) + dfwhm = SFD_DFWHM(sfd) + mfwhm = SFD_MFWHM(sfd) + gfwhm = SFD_GFWHM(sfd) + + call asifree (SFD_ASI1(sfd)) + call asifree (SFD_ASI2(sfd)) + } then + call erract (EA_WARN) + + # Finish up + call stf_free (sf) + call sfree (sp) +end + + +# STF_FREE -- Free the starfocus data structures. + +procedure stf_free (sf) + +pointer sf #I Starfocus structure +int i + +begin + do i = 1, SF_NSTARS(sf) + call mfree (SF_SFS(sf,i), TY_STRUCT) + do i = 1, SF_NFOCUS(sf) + call mfree (SF_SFF(sf,i), TY_STRUCT) + do i = 1, SF_NIMAGES(sf) + call mfree (SF_SFI(sf,i), TY_STRUCT) + call mfree (SF_STARS(sf), TY_POINTER) + call mfree (SF_FOCUS(sf), TY_POINTER) + call mfree (SF_IMAGES(sf), TY_POINTER) + SF_NSTARS(sf) = 0 + SF_NFOCUS(sf) = 0 + SF_NIMAGES(sf) = 0 +end diff --git a/pkg/images/tv/imexamine/stfprofile.x b/pkg/images/tv/imexamine/stfprofile.x new file mode 100644 index 00000000..d26c085d --- /dev/null +++ b/pkg/images/tv/imexamine/stfprofile.x @@ -0,0 +1,1189 @@ +include +include +include +include +include +include "starfocus.h" + + +# STF_FIND -- Find the object and return the data raster and object center. +# STF_BKGD -- Compute the background. +# STF_PROFILE -- Compute enclosed flux profile, derivative, and moments. +# STF_NORM -- Renormalized enclosed flux profile +# STF_WIDTHS -- Set widths. +# STF_I2R -- Radius from sample index. +# STF_R2I -- Sample index from radius. +# STF_R2N -- Number of subsamples from radius. +# STF_MODEL -- Return model values. +# STF_DFWHM -- Direct FWHM from profile. +# STF_FWHMS -- Measure FWHM vs level. +# STF_RADIUS -- Measure the radius at the specified level. +# STF_FIT -- Fit model. +# STF_GAUSS1 -- Gaussian function used in NLFIT. +# STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. +# STF_MOFFAT1 -- Moffat function used in NLFIT. +# STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. + + +# STF_FIND -- Find the object and return the data raster and object center. +# Centering uses centroid of marginal distributions of data above the mean. + +procedure stf_find (sf, sfd, im) + +pointer sf #I Starfocus pointer +pointer sfd #I Object pointer +pointer im #I Image pointer + +long lseed +int i, j, k, x1, x2, y1, y2, nx, ny, npts +real radius, buffer, width, xc, yc, xlast, ylast, r1, r2 +real mean, sum, sum1, sum2, sum3, asumr(), urand() +pointer data, ptr, imgs2r() +errchk imgs2r + +begin + radius = max (3., SFD_RADIUS(sfd)) + buffer = SF_SBUF(sf) + width = SF_SWIDTH(sf) + + xc = SFD_X(sfd) + yc = SFD_Y(sfd) + r1 = radius + buffer + width + r2 = radius + + # Iterate on the center finding. + do k = 1, 3 { + + # Extract region around current center. + xlast = xc + ylast = yc + + x1 = max (1-NBNDRYPIX, nint (xc - r2)) + x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r2)) + nx = x2 - x1 + 1 + y1 = max (1-NBNDRYPIX, nint (yc - r2)) + y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r2)) + ny = y2 - y1 + 1 + npts = nx * ny + data = imgs2r (im, x1, x2, y1, y2) + + # Find center of gravity of marginal distributions above mean. + npts = nx * ny + sum = asumr (Memr[data], npts) + mean = sum / nx + sum1 = 0. + sum2 = 0. + + do i = x1, x2 { + ptr = data + i - x1 + sum3 = 0. + do j = y1, y2 { + sum3 = sum3 + Memr[ptr] + ptr = ptr + nx + } + sum3 = sum3 - mean + if (sum3 > 0.) { + sum1 = sum1 + i * sum3 + sum2 = sum2 + sum3 + } + } + if (sum2 <= 0) + call error (1, "Centering failed to converge") + xc = sum1 / sum2 + if (xlast - xc > 0.2 * nx) + xc = xlast - 0.2 * nx + if (xc - xlast > 0.2 * nx) + xc = xlast + 0.2 * nx + + ptr = data + mean = sum / ny + sum1 = 0. + sum2 = 0. + do j = y1, y2 { + sum3 = 0. + do i = x1, x2 { + sum3 = sum3 + Memr[ptr] + ptr = ptr + 1 + } + sum3 = sum3 - mean + if (sum3 > 0.) { + sum1 = sum1 + j * sum3 + sum2 = sum2 + sum3 + } + } + if (sum2 <= 0) + call error (1, "Centering failed to converge") + yc = sum1 / sum2 + if (ylast - yc > 0.2 * ny) + yc = ylast - 0.2 * ny + if (yc - ylast > 0.2 * ny) + yc = ylast + 0.2 * ny + + if (nint(xc) == nint(xlast) && nint(yc) == nint(ylast)) + break + } + + # Get a new centered raster if necessary. + if (nint(xc) != nint(xlast) || nint(yc) != nint(ylast) || r2 < r1) { + x1 = max (1-NBNDRYPIX, nint (xc - r1)) + x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r1)) + nx = x2 - x1 + 1 + y1 = max (1-NBNDRYPIX, nint (yc - r1)) + y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r1)) + ny = y2 - y1 + 1 + npts = nx * ny + data = imgs2r (im, x1, x2, y1, y2) + } + + # Add a dither for integer data. The random numbers are always + # the same to provide reproducibility. + + i = IM_PIXTYPE(im) + if (i == TY_SHORT || i == TY_INT || i == TY_LONG) { + lseed = 1 + do i = 0, npts-1 + Memr[data+i] = Memr[data+i] + urand(lseed) - 0.5 + } + + SFD_DATA(sfd) = data + SFD_X1(sfd) = x1 + SFD_X2(sfd) = x2 + SFD_Y1(sfd) = y1 + SFD_Y2(sfd) = y2 + SFD_X(sfd) = xc + SFD_Y(sfd) = yc +end + + +# STF_BKGD -- Compute the background. +# A mode is estimated from the minimum slope in the sorted background pixels +# with a bin width of 5%. + +procedure stf_bkgd (sf, sfd) + +pointer sf #I Parameter structure +pointer sfd #I Star structure + +int i, j, x1, x2, y1, y2, xc, yc, nx, ny, npts, ns, nsat +real sat, bkgd, miso +real r, r1, r2, r3, dx, dy, dz +pointer sp, data, bdata, ptr + +begin + data = SFD_DATA(sfd) + x1 = SFD_X1(sfd) + x2 = SFD_X2(sfd) + y1 = SFD_Y1(sfd) + y2 = SFD_Y2(sfd) + xc = SFD_X(sfd) + yc = SFD_Y(sfd) + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + npts = nx * ny + + ns = 0 + nsat = 0 + r1 = SFD_RADIUS(sfd) ** 2 + r2 = (SFD_RADIUS(sfd) + SF_SBUF(sf)) ** 2 + r3 = (SFD_RADIUS(sfd) + SF_SBUF(sf) + SF_SWIDTH(sf)) ** 2 + sat = SF_SAT(sf) + if (IS_INDEF(sat)) + sat = MAX_REAL + + call smark (sp) + call salloc (bdata, npts, TY_REAL) + + ptr = data + do j = y1, y2 { + dy = (yc - j) ** 2 + do i = x1, x2 { + dx = (xc - i) ** 2 + r = dx + dy + if (r <= r1) { + if (Memr[ptr] >= sat) + nsat = nsat + 1 + } else if (r >= r2 && r <= r3) { + Memr[bdata+ns] = Memr[ptr] + ns = ns + 1 + } + ptr = ptr + 1 + } + } + + if (ns > 9) { + call asrtr (Memr[bdata], Memr[bdata], ns) + r = Memr[bdata+ns-1] - Memr[bdata] + bkgd = Memr[bdata] + r / 2 + miso = r / 2 + + j = 1 + 0.50 * ns + do i = 0, ns - j { + dz = Memr[bdata+i+j-1] - Memr[bdata+i] + if (dz < r) { + r = dz + bkgd = Memr[bdata+i] + dz / 2 + miso = dz / 2 + } + } + } else { + bkgd = 0. + miso = 0. + } + + SFD_BKGD1(sfd) = bkgd + SFD_BKGD(sfd) = bkgd + SFD_MISO(sfd) = miso + SFD_NSAT(sfd) = nsat + + call sfree (sp) +end + + +# STF_PROFILE -- Compute enclosed flux profile, derivative, direct FWHM, and +# profile moments.. +# 1. The flux profile is normalized at the maximum value. +# 2. The radial profile is computed from the numerical derivative of the +# enclose flux profile. + +procedure stf_profile (sf, sfd) + +pointer sf #I Parameter structure +pointer sfd #I Star structure + +int np +real radius, xc, yc + +int i, j, k, l, m, ns, nx, ny, x1, x2, y1, y2 +real bkgd, miso, sigma, peak +real r, r1, r2, r3, dx, dy, dx1, dx2, dy1, dy2, dz, xx, yy, xy, ds, da +pointer sp, data, profile, ptr, asi, msi, gs +int stf_r2n() +real asieval(), msieval(), gseval(), stf_i2r(), stf_r2i() +errchk asiinit, asifit, msiinit, msifit, gsrestore + +real gsdata[24] +data gsdata/ 1., 4., 4., 1., 0., 0.6726812, 1., 2., 1.630641, 0.088787, + 0.00389378, -0.001457133, 0.3932125, -0.1267456, -0.004864541, + 0.00249941, 0.03078612, 0.02731274, -4.875850E-4, 2.307464E-4, + -0.002134843, 0.007603908, -0.002552385, -8.010564E-4/ + +begin + data = SFD_DATA(sfd) + x1 = SFD_X1(sfd) + x2 = SFD_X2(sfd) + y1 = SFD_Y1(sfd) + y2 = SFD_Y2(sfd) + xc = SFD_X(sfd) + yc = SFD_Y(sfd) + bkgd = SFD_BKGD(sfd) + miso = SFD_MISO(sfd) + radius = SFD_RADIUS(sfd) + np = SFD_NP(sfd) + + nx = x2 - x1 + 1 + ny = y2 - y1 + 1 + + # Use an image interpolator fit to the data. + call msiinit (msi, II_BISPLINE3) + call msifit (msi, Memr[data], nx, ny, nx) + + # To avoid trying to interpolate outside the center of the + # edge pixels, a requirement of the interpolator functions, + # we reset the data limits. + x1 = x1 + 1 + x2 = x2 - 1 + y1 = y1 + 1 + y2 = y2 - 1 + + # Compute the enclosed flux profile, its derivative, and moments. + call smark (sp) + call salloc (profile, np, TY_REAL) + call aclrr (Memr[profile], np) + + xx = 0. + yy = 0. + xy = 0. + do j = y1, y2 { + ptr = data + (j-y1+1)*nx + 1 + dy = j - yc + do i = x1, x2 { + dx = i - xc + + # Set the subpixel sampling which may be a function of radius. + r = sqrt (dx * dx + dy * dy) + ns = stf_r2n (r) + ds = 1. / ns + da = ds * ds + dz = 0.5 + 0.5 * ds + + # Sum the interpolator values over the subpixels and compute + # an offset to give the correct total for the pixel. + + r2 = 0. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dy2 = dy1 * dy1 + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + dx2 = dx1 * dx1 + r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + r2 = r2 + r1 + } + } + + r1 = Memr[ptr] - bkgd + ptr = ptr + 1 + r2 = r1 - r2 * da + + # Accumulate the enclosed flux over the sub pixels. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dy2 = dy1 * dy1 + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + dx2 = dx1 * dx1 + r = max (0., sqrt (dx2 + dy2) - ds / 2) + if (r < radius) { + r1 = da * (msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + + r2) + + # Use approximation for fractions of a subpixel. + for (m=stf_r2i(r)+1; m<=np; m=m+1) { + r3 = (stf_i2r (real(m)) - r) / ds + if (r3 >= 1.) + break + Memr[profile+m-1] = Memr[profile+m-1] + r3 * r1 + } + + # The subpixel is completely within these radii. + for (; m<=np; m=m+1) + Memr[profile+m-1] = Memr[profile+m-1] + r1 + + # Accumulate the moments above an isophote. + if (r1 > miso) { + xx = xx + dx2 * r1 + yy = yy + dy2 * r1 + xy = xy + dx1 * dy1 * r1 + } + } + } + } + } + } + + call msifree (msi) + + # Compute the ellipticity and position angle from the moments. + r = (xx + yy) + if (r > 0.) { + r1 = (xx - yy) / r + r2 = 2 * xy / r + SFD_E(sfd) = sqrt (r1**2 + r2**2) + SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) + } else { + SFD_E(sfd) = 0. + SFD_PA(sfd) = 0. + } + + # The magnitude and profile normalization is from the max enclosed flux. + call alimr (Memr[profile], np, r, SFD_M(sfd)) + if (SFD_M(sfd) <= 0.) + call error (1, "Invalid flux profile") + call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) + + # Fit interpolator to the enclosed flux profile. + call asiinit (asi, II_SPLINE3) + call asifit (asi, Memr[profile], np) + SFD_ASI1(sfd) = asi + + # Estimate a gaussian sigma (actually sqrt(2)*sigma) and if it is + # it is small subtract the gaussian so that the image interpolator + # can more accurately estimate subpixel values. + + #call stf_radius (sf, sfd, SF_LEVEL(sf), r) + #sigma = r / sqrt (log (1/(1-SF_LEVEL(sf)))) + call stf_radius (sf, sfd, 0.8, r) + r = r / SF_SCALE(sf) + sigma = 2 * r * sqrt (log(2.) / log (1/(1-0.8))) + if (sigma < 5.) { + if (sigma <= 2.) { + call gsrestore (gs, gsdata) + dx = xc - nint (xc) + dy = yc - nint (yc) + r = sqrt (dx * dx + dy * dy) + dx = 1. + ds = abs (sigma - gseval (gs, r, dx)) + for (da = 1.; da <= 2.; da = da + .01) { + dz = abs (sigma - gseval (gs, r, da)) + if (dz < ds) { + ds = dz + dx = da + } + } + sigma = dx + call gsfree (gs) + } + + sigma = sigma / (2 * sqrt (log(2.))) + sigma = sigma * sigma + + # Compute the peak that gives the correct central pixel value. + i = nint (xc) + j = nint (yc) + dx = i - xc + dy = j - yc + r = sqrt (dx * dx + dy * dy) + ns = stf_r2n (r) + ds = 1. / ns + da = ds * ds + dz = 0.5 + 0.5 * ds + + r1 = 0. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dy2 = dy1 * dy1 + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + dx2 = dx1 * dx1 + r2 = (dx2 + dy2) / sigma + if (r2 < 25.) + r1 = r1 + exp (-r2) + } + } + ptr = data + (j - y1 + 1) * nx + (i - x1 + 1) + peak = (Memr[ptr] - bkgd) / (r1 * da) + + # Subtract the gaussian from the data. + do j = y1, y2 { + ptr = data + (j - y1 + 1) * nx + 1 + dy = j - yc + do i = x1, x2 { + dx = i - xc + r = sqrt (dx * dx + dy * dy) + ns = stf_r2n (r) + ds = 1. / ns + da = ds * ds + dz = 0.5 + 0.5 * ds + + r1 = 0. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dy2 = dy1 * dy1 + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + dx2 = dx1 * dx1 + r2 = (dx2 + dy2) / sigma + if (r2 < 25.) + r1 = r1 + peak * exp (-r2) + } + } + Memr[ptr] = Memr[ptr] - r1 * da + ptr = ptr + 1 + } + } + + # Fit the image interpolator to the residual data. + call msiinit (msi, II_BISPLINE3) + call msifit (msi, Memr[data], nx, ny, nx) + + # Recompute the enclosed flux profile and moments + # using the gaussian plus image interpolator fit to the residuals. + + call aclrr (Memr[profile], np) + + xx = 0. + yy = 0. + xy = 0. + do j = y1, y2 { + ptr = data + (j - y1 + 1) * nx + 1 + dy = j - yc + do i = x1, x2 { + dx = i - xc + r = sqrt (dx * dx + dy * dy) + ns = stf_r2n (r) + ds = 1. / ns + da = ds * ds + dz = 0.5 + 0.5 * ds + + # Compute interpolator correction. + r2 = 0. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + r2 = r2 + r1 + } + } + + r1 = Memr[ptr] - bkgd + ptr = ptr + 1 + r2 = r1 - r2 * da + + # Accumulate the enclosed flux and moments. + dy1 = dy - dz + do l = 1, ns { + dy1 = dy1 + ds + dy2 = dy1 * dy1 + dx1 = dx - dz + do k = 1, ns { + dx1 = dx1 + ds + dx2 = dx1 * dx1 + r3 = (dx2 + dy2) / sigma + if (r3 < 25.) + r3 = peak * exp (-r3) + else + r3 = 0. + r = max (0., sqrt (dx2 + dy2) - ds / 2) + if (r < radius) { + r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + r1 = da * (r1 + r2 + r3) + + for (m=stf_r2i(r)+1; m<=np; m=m+1) { + r3 = (stf_i2r (real(m)) - r) / ds + if (r3 >= 1.) + break + Memr[profile+m-1] = Memr[profile+m-1] + + r3 * r1 + } + for (; m<=np; m=m+1) + Memr[profile+m-1] = Memr[profile+m-1] + r1 + + if (r1 > miso) { + xx = xx + dx2 * r1 + yy = yy + dy2 * r1 + xy = xy + dx1 * dy1 * r1 + } + } + } + } + } + } + + call msifree (msi) + + # Recompute the moments, magnitude, normalized flux, and interp. + r = (xx + yy) + if (r > 0.) { + r1 = (xx - yy) / r + r2 = 2 * xy / r + SFD_E(sfd) = sqrt (r1**2 + r2**2) + SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) + } else { + SFD_E(sfd) = 0. + SFD_PA(sfd) = 0. + } + + call alimr (Memr[profile], np, r, SFD_M(sfd)) + if (SFD_M(sfd) <= 0.) + call error (1, "Invalid flux profile") + call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) + + call asifit (asi, Memr[profile], np) + SFD_ASI1(sfd) = asi + } + + # Compute derivative of enclosed flux profile and fit an image + # interpolator. + + dx = 0.25 + Memr[profile] = 0. + ns = 0 + do i = 1, np { + r = stf_i2r (real(i)) + r2 = stf_r2i (r + dx) + if (r2 > np) { + k = i + break + } + r1 = stf_r2i (r - dx) + if (r1 < 1) { + if (i > 1) { + dy = asieval (asi, real(i)) / r**2 + Memr[profile] = (ns * Memr[profile] + dy) / (ns + 1) + ns = ns + 1 + } + j = i + } else { + dy = (asieval (asi, r2) - asieval (asi, r1)) / + (4 * r * dx) + Memr[profile+i-1] = dy + } + } + do i = 2, j + Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * + (i - 1) + Memr[profile] + do i = k, np + Memr[profile+i-1] = Memr[profile+k-2] + + call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) + call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) + call asiinit (asi, II_SPLINE3) + call asifit (asi, Memr[profile], np) + SFD_ASI2(sfd) = asi + #SF_XP1(sf) = j+1 + SF_XP1(sf) = 1 + SF_XP2(sf) = k-1 + + call sfree (sp) +end + + +# STF_NORM -- Renormalize the enclosed flux profile. + +procedure stf_norm (sf, sfd, x, y) + +pointer sf #I Parameter structure +pointer sfd #I Star structure +real x #I Radius +real y #I Flux + +int npmax, np +pointer asi + +int i, j, k +real r, r1, r2, dx, dy +pointer sp, profile +real asieval(), stf_i2r(), stf_r2i() +errchk asifit + +begin + npmax = SFD_NPMAX(sfd) + np = SFD_NP(sfd) + asi = SFD_ASI1(sfd) + + call smark (sp) + call salloc (profile, npmax, TY_REAL) + + # Renormalize the enclosed flux profile. + if (IS_INDEF(x) || x <= 0.) { + dy = SFD_BKGD(sfd) - SFD_BKGD1(sfd) + SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy + do i = 1, npmax + Memr[profile+i-1] = asieval (asi, real(i)) + + dy * stf_i2r(real(i)) ** 2 + call alimr (Memr[profile], np, r1, r2) + call adivkr (Memr[profile], r2, Memr[profile], npmax) + } else if (IS_INDEF(y)) { + r = max (1., min (real(np), stf_r2i (x))) + r2 = asieval (asi, r) + if (r2 <= 0.) + return + do i = 1, npmax + Memr[profile+i-1] = asieval (asi, real(i)) + call adivkr (Memr[profile], r2, Memr[profile], npmax) + } else { + r = max (1., min (real(np), stf_r2i (x))) + r1 = asieval (asi, r) + dy = (y - r1) / x ** 2 + SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy + do i = 1, npmax + Memr[profile+i-1] = asieval (asi, real(i)) + + dy * stf_i2r(real(i)) ** 2 + } + + call asifit (asi, Memr[profile], npmax) + SFD_ASI1(sfd) = asi + + # Compute derivative of enclosed flux profile and fit an image + # interpolator. + + dx = 0.25 + do i = 1, npmax { + r = stf_i2r (real(i)) + r2 = stf_r2i (r + dx) + if (r2 > np) { + k = i + break + } + r1 = stf_r2i (r - dx) + if (r1 < 1) { + if (i > 1) { + dy = asieval (asi, real(i)) / r**2 + Memr[profile] = dy + } + j = i + } else { + dy = (asieval (asi, r2) - asieval (asi, r1)) / + (4 * r * dx) + Memr[profile+i-1] = dy + } + } + do i = 2, j + Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * + (i - 1) + Memr[profile] + do i = k, npmax + Memr[profile+i-1] = Memr[profile+k-2] + + call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) + call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) + asi = SFD_ASI2(sfd) + call asifit (asi, Memr[profile], np) + SFD_ASI2(sfd) = asi + #SF_XP1(sf) = min (j+1, np) + SF_XP1(sf) = 1 + SF_XP2(sf) = min (k-1, np) + + call sfree (sp) +end + + +# STF_WIDTHS -- Set the widhts. + +procedure stf_widths (sf, sfd) + +pointer sf #I Main data structure +pointer sfd #I Star data structure + +errchk stf_radius, stf_dfwhm, stf_fit + +begin + call stf_radius (sf, sfd, SF_LEVEL(sf), SFD_R(sfd)) + call stf_dfwhm (sf, sfd) + call stf_fit (sf, sfd) + + switch (SF_WCODE(sf)) { + case 1: + SFD_W(sfd) = SFD_R(sfd) + case 2: + SFD_W(sfd) = SFD_DFWHM(sfd) + case 3: + SFD_W(sfd) = SFD_GFWHM(sfd) + case 4: + SFD_W(sfd) = SFD_MFWHM(sfd) + } +end + + +# STF_I2R -- Compute radius from sample index. + +real procedure stf_i2r (i) + +real i #I Index +real r #O Radius + +begin + if (i < 20) + r = 0.05 * i + else if (i < 30) + r = 0.1 * i - 1 + else if (i < 40) + r = 0.2 * i - 4 + else if (i < 50) + r = 0.5 * i - 16 + else + r = i - 41 + return (r) +end + + +# STF_R2I -- Compute sample index from radius. + +real procedure stf_r2i (r) + +real r #I Radius +real i #O Index + +begin + if (r < 1) + i = 20 * r + else if (r < 2) + i = 10 * (r + 1) + else if (r < 4) + i = 5 * (r + 4) + else if (r < 9) + i = 2 * (r + 16) + else + i = r + 41 + return (i) +end + + +# STF_R2N -- Compute number of subsamples from radius. + +int procedure stf_r2n (r) + +real r #I Radius +int n #O Number of subsamples + +begin + if (r < 1) + n = 20 + else if (r < 2) + n = 10 + else if (r < 4) + n = 5 + else if (r < 9) + n = 2 + else + n = 1 + return (n) +end + + +# STF_MODEL -- Return model value. + +procedure stf_model (sf, sfd, r, profile, flux) + +pointer sf #I Main data structure +pointer sfd #I Star data structure +real r #I Radius at level +real profile #I Profile value +real flux #I Enclosed flux value + +real x, x1, x2, r1, r2, dr + +begin + dr = 0.25 * SF_SCALE(sf) + r1 = r - dr + r2 = r + dr + if (r1 < 0.) { + r1 = dr + r2 = r1 + dr + } + + switch (SF_WCODE(sf)) { + case 3: + x = r**2 / (2. * SFD_SIGMA(sfd)**2) + if (x < 20.) + flux = 1 - exp (-x) + else + flux = 0. + + x1 = r1**2 / (2. * SFD_SIGMA(sfd)**2) + x2 = r2**2 / (2. * SFD_SIGMA(sfd)**2) + if (x2 < 20.) { + x1 = 1 - exp (-x1) + x2 = 1 - exp (-x2) + } else { + x1 = 1. + x2 = 1. + } + if (r <= dr) { + x1 = x1 / dr ** 2 + x2 = x2 / (4 * dr ** 2) + profile = (x2 - x1) / dr * r + x1 + } else { + profile = (x2 - x1) / (4 * r * dr) + } + default: + x = 1 + (r / SFD_ALPHA(sfd)) ** 2 + flux = 1 - x ** (1 - SFD_BETA(sfd)) + + x1 = 1 + (r1 / SFD_ALPHA(sfd)) ** 2 + x2 = 1 + (r2 / SFD_ALPHA(sfd)) ** 2 + x1 = 1 - x1 ** (1 - SFD_BETA(sfd)) + x2 = 1 - x2 ** (1 - SFD_BETA(sfd)) + if (r <= dr) { + x1 = x1 / dr ** 2 + x2 = x2 / (4 * dr ** 2) + profile = (x2 - x1) / dr * r + x1 + } else { + profile = (x2 - x1) / (4 * r * dr) + } + } +end + + +# STF_DFWHM -- Direct FWHM from profile. + +procedure stf_dfwhm (sf, sfd) + +pointer sf #I Main data structure +pointer sfd #I Star data structure + +int np +real r, rpeak, profile, peak, asieval(), stf_i2r() +pointer asi + +begin + asi = SFD_ASI2(sfd) + np = SFD_NP(sfd) + + rpeak = 1. + peak = 0. + for (r=1.; r <= np; r = r + 0.01) { + profile = asieval (asi, r) + if (profile > peak) { + rpeak = r + peak = profile + } + } + + peak = peak / 2. + for (r=rpeak; r <= np && asieval (asi, r) > peak; r = r + 0.01) + ; + + SFD_DFWHM(sfd) = 2 * stf_i2r (r) * SF_SCALE(sf) +end + + +# STF_FWHMS -- Measure FWHM vs level. + +procedure stf_fwhms (sf, sfd) + +pointer sf #I Main data structure +pointer sfd #I Star data structure + +int i +real level, r + +begin + do i = 1, 19 { + level = i * 0.05 + call stf_radius (sf, sfd, level, r) + switch (SF_WCODE(sf)) { + case 3: + SFD_FWHM(sfd,i) = 2 * r * sqrt (log (2.) / log (1/(1-level))) + default: + r = r / sqrt ((1.-level)**(1./(1.-SFD_BETA(sfd))) - 1.) + SFD_FWHM(sfd,i) = 2 * r * sqrt (2.**(1./SFD_BETA(sfd))-1.) + } + } +end + + +# STF_RADIUS -- Measure the radius at the specified level. + +procedure stf_radius (sf, sfd, level, r) + +pointer sf #I Main data structure +pointer sfd #I Star data structure +real level #I Level to measure +real r #O Radius + +int np +pointer asi +real f, fmax, rmax, asieval(), stf_i2r() + +begin + np = SFD_NP(sfd) + asi = SFD_ASI1(sfd) + + for (r=1; r <= np && asieval (asi, r) < level; r = r + 0.01) + ; + if (r > np) { + fmax = 0. + rmax = 0. + for (r=1; r <= np; r = r + 0.01) { + f = asieval (asi, r) + if (f > fmax) { + fmax = f + rmax = r + } + } + r = rmax + } + r = stf_i2r (r) * SF_SCALE(sf) +end + + +# STF_FIT -- Fit models to enclosed flux. + +procedure stf_fit (sf, sfd) + +pointer sf #I Main data structure +pointer sfd #I Star data structure + +int i, j, n, np, pfit[2] +real beta, z, params[3] +pointer asi, nl +pointer sp, x, y, w + +int locpr() +real asieval(), stf_i2r() +extern stf_gauss1(), stf_gauss2(), stf_moffat1(), stf_moffat2() +errchk nlinitr, nlfitr + +data pfit/2,3/ + +begin + np = SFD_NP(sfd) + asi = SFD_ASI1(sfd) + + call smark (sp) + call salloc (x, np, TY_REAL) + call salloc (y, np, TY_REAL) + call salloc (w, np, TY_REAL) + + n = 0 + j = 0 + do i = 1, np { + z = 1. - max (0., asieval (asi, real(i))) + if (n > np/3 && z < 0.5) + break + if ((n < np/3 && z > 0.01) || z > 0.5) + j = n + + Memr[x+n] = stf_i2r (real(i)) * SF_SCALE(sf) + Memr[y+n] = z + Memr[w+n] = 1. + n = n + 1 + } + + # Gaussian. + np = 1 + params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) + params[1] = 1 + call nlinitr (nl, locpr (stf_gauss1), locpr (stf_gauss2), + params, params, 2, pfit, np, .001, 100) + call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) + if (i != SINGULAR && i != NO_DEG_FREEDOM) { + call nlpgetr (nl, params, i) + if (params[2] < 0.) + params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) + } + SFD_SIGMA(sfd) = params[2] + SFD_GFWHM(sfd) = 2 * SFD_SIGMA(sfd) * sqrt (2. * log (2.)) + + # Moffat. + if (SF_BETA(sf) < 1.1) { + call nlfreer (nl) + call sfree (sp) + call error (1, "Cannot measure FWHM - Moffat beta too small") + } + + beta = SF_BETA(sf) + if (IS_INDEFR(beta)) { + beta = 2.5 + np = 2 + } else { + np = 1 + } + params[3] = 1 - beta + params[2] = Memr[x+j] / sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) + params[1] = 1 + call nlinitr (nl, locpr (stf_moffat1), locpr (stf_moffat2), + params, params, 3, pfit, np, .001, 100) + call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) + if (i != SINGULAR && i != NO_DEG_FREEDOM) { + call nlpgetr (nl, params, i) + if (params[2] < 0.) { + params[3] = 1. - beta + params[2] = Memr[x+j] / + sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) + } + } + SFD_ALPHA(sfd) = params[2] + SFD_BETA(sfd) = 1 - params[3] + SFD_MFWHM(sfd) = 2 * SFD_ALPHA(sfd) * sqrt (2.**(1./SFD_BETA(sfd))-1.) + + call nlfreer (nl) + call sfree (sp) +end + + +# STF_GAUSS1 -- Gaussian function used in NLFIT. The parameters are the +# amplitude and sigma and the input variable is the radius. + +procedure stf_gauss1 (x, nvars, p, np, z) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +int np #I Number of parameters +real z #O Function return + +real r2 + +begin + r2 = x[1]**2 / (2 * p[2]**2) + if (abs (r2) > 20.) + z = 0. + else + z = p[1] * exp (-r2) +end + + +# STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. The parameters +# are the amplitude and sigma and the input variable is the radius. + +procedure stf_gauss2 (x, nvars, p, dp, np, z, der) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +real dp[np] #I Dummy array of parameters increments +int np #I Number of parameters +real z #O Function return +real der[np] #O Derivatives + +real r2 + +begin + r2 = x[1]**2 / (2 * p[2]**2) + if (abs (r2) > 20.) { + z = 0. + der[1] = 0. + der[2] = 0. + } else { + der[1] = exp (-r2) + z = p[1] * der[1] + der[2] = z * 2 * r2 / p[2] + } +end + + +# STF_MOFFAT1 -- Moffat function used in NLFIT. The parameters are the +# amplitude, alpha squared, and beta and the input variable is the radius. + +procedure stf_moffat1 (x, nvars, p, np, z) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +int np #I Number of parameters +real z #O Function return + +real y + +begin + y = 1 + (x[1] / p[2]) ** 2 + if (abs (y) > 20.) + z = 0. + else + z = p[1] * y ** p[3] +end + + +# STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. The +# parameters are the amplitude, alpha squared, and beta and the input +# variable is the radius. + +procedure stf_moffat2 (x, nvars, p, dp, np, z, der) + +real x[nvars] #I Input variables +int nvars #I Number of variables +real p[np] #I Parameter vector +real dp[np] #I Dummy array of parameters increments +int np #I Number of parameters +real z #O Function return +real der[np] #O Derivatives + +real y + +begin + y = 1 + (x[1] / p[2]) ** 2 + if (abs (y) > 20.) { + z = 0. + der[1] = 0. + der[2] = 0. + der[3] = 0. + } else { + der[1] = y ** p[3] + z = p[1] * der[1] + der[2] = -2 * z / y * p[3] / p[2] * (x[1] / p[2]) ** 2 + der[3] = z * log (y) + } +end diff --git a/pkg/images/tv/imexamine/t_imexam.x b/pkg/images/tv/imexamine/t_imexam.x new file mode 100644 index 00000000..089e74fc --- /dev/null +++ b/pkg/images/tv/imexamine/t_imexam.x @@ -0,0 +1,352 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "imexam.h" + +define HELP "iraf$lib/scr/imexamine.key" +define PROMPT "imexamine options" +define SZ_IMLIST 512 + + +# T_IMEXAMINE -- Examine images using image display, graphics, and text output. + +procedure t_imexamine () + +real x, y +pointer sp, cmd, imname, imlist, gp, ie, im +int curtype, key, redraw, mode, nframes, nargs + +bool clgetb() +pointer gopen(), ie_gimage(), imtopen() +int imd_wcsver(), ie_gcur(), ie_getnframes() +int btoi(), clgeti(), imtlen() + +begin + call smark (sp) + call salloc (ie, IE_LEN, TY_STRUCT) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (imlist, SZ_IMLIST, TY_CHAR) + + # Initialize the imexamine descriptor. + call aclri (Memi[ie], IE_LEN) + + # Determine if we will be accessing the image display, and if so, + # the maximum number of frames to be accessed. + + IE_USEDISPLAY(ie) = btoi (clgetb ("use_display")) + if (IE_USEDISPLAY(ie) == YES) { + if (imd_wcsver() == 0) + ; + iferr (nframes = ie_getnframes (ie)) { + call eprintf ("cannot access display\n") + IE_USEDISPLAY(ie) = NO + } + } + + # Get the list of images to be examined, if given on the command + # line. If no images are explicitly listed use the display to + # determine the images to be examined. + + nargs = clgeti ("$nargs") + if (nargs > 0) { + call clgstr ("input", Memc[imlist], SZ_IMLIST) + IE_LIST(ie) = imtopen (Memc[imlist]) + IE_LISTLEN(ie) = imtlen (IE_LIST(ie)) + IE_INDEX(ie) = 1 + + if (nargs >= 1) { + # Set user specified display frame. + IE_DFRAME(ie) = 100 * clgeti ("frame") + 1 + IE_NEWFRAME(ie) = IE_DFRAME(ie) + if (IE_USEDISPLAY(ie) == YES) { + nframes = max (IE_NEWFRAME(ie)/100, nframes) + IE_NFRAMES(ie) = nframes + } + } else { + # If we have to display an image and no frame was specified, + # default to frame 1 (should use the current display frame + # but we don't have a cursor read yet to tell us what it is). + + IE_DFRAME(ie) = 101 + IE_NEWFRAME(ie) = 101 + } + + } else { + IE_INDEX(ie) = 1 + IE_DFRAME(ie) = 101 + IE_NEWFRAME(ie) = 101 + } + + # Set the wcs, logfile and graphics. + call clgstr ("wcs", IE_WCSNAME(ie), IE_SZFNAME) + IE_LOGFD(ie) = NULL + call clgstr ("logfile", IE_LOGFILE(ie), IE_SZFNAME) + if (clgetb ("keeplog")) + iferr (call ie_openlog (ie)) + call erract (EA_WARN) + + call clgstr ("graphics", Memc[cmd], SZ_LINE) + gp = gopen (Memc[cmd], NEW_FILE+AW_DEFER, STDGRAPH) + + # Initialize the data structure. + IE_IM(ie) = NULL + IE_DS(ie) = NULL + IE_PP(ie) = NULL + IE_MAPFRAME(ie) = 0 + IE_NFRAMES(ie) = nframes + IE_ALLFRAMES(ie) = btoi (clgetb ("allframes")) + IE_GTYPE(ie) = NULL + IE_XORIGIN(ie) = 0. + IE_YORIGIN(ie) = 0. + + # Access the first image. If an image list was specified and the + # display is being used, this will set the display frame to the first + # image listed, or display the first image if not already loaded into + # the display. + + if (IE_LIST(ie) != NULL) + im = ie_gimage (ie, YES) + + # Enter the cursor loop. The commands are returned by the + # IE_GCUR procedure. + + x = 1. + y = 1. + redraw = NO + curtype = 'i' + mode = NEW_FILE + + while (ie_gcur (ie, curtype, x,y, key, Memc[cmd], SZ_LINE) != EOF) { + # Check to see if the user has changed frames on us while in + # examine-image-list mode. + + if (IE_USEDISPLAY(ie) == YES && IE_LIST(ie) != NULL && + IE_NEWFRAME(ie)/100 != IE_MAPFRAME(ie)/100) { + call ie_imname (IE_DS(ie), IE_NEWFRAME(ie), Memc[imname], + SZ_FNAME) + call ie_addimage (ie, Memc[imname], imlist) + } + + # Set workstation state. + switch (key) { + case 'a', 'b', 'd', 'm', 't', 'w', 'x', 'y', 'z', ',': + call gdeactivate (gp, 0) + } + + # Act on the command key. + switch (key) { + case '?': # Print help + call gpagefile (gp, HELP, PROMPT) + case ':': # Process colon commands + call ie_colon (ie, Memc[cmd], gp, redraw) + if (redraw == YES) { + x = INDEF + y = INDEF + } + case 'f': # Redraw frame + redraw = YES + x = INDEF + y = INDEF + case 'a': # Aperture photometry + call ie_rimexam (NULL, NULL, ie, x, y) + case ',': # Aperture photometry + call ie_qrimexam (NULL, NULL, ie, x, y) + + case 'b': # Print image region coordinates + call printf ("%4d %4d %4d %4d\n") + call pargi (IE_IX1(ie)) + call pargi (IE_IX2(ie)) + call pargi (IE_IY1(ie)) + call pargi (IE_IY2(ie)) + + if (IE_LOGFD(ie) != NULL) { + call fprintf (IE_LOGFD(ie), "%4d %4d %4d %4d\n") + call pargi (IE_IX1(ie)) + call pargi (IE_IX2(ie)) + call pargi (IE_IY1(ie)) + call pargi (IE_IY2(ie)) + } + + case 'c','e','h','j','k','s','l','r','u','v','.': # Graphs + IE_GTYPE(ie) = key + redraw = YES + + case 'd': # Load the display. + # Query the user for the frame to be loaded, the current + # display frame being the default. + + call clgstr ("image", Memc[imname], SZ_FNAME) + call clputi ("frame", IE_NEWFRAME(ie)/100) + IE_DFRAME(ie) = 100 * clgeti ("frame") + 1 + IE_NEWFRAME(ie) = IE_DFRAME(ie) + + if (IE_LIST(ie) != NULL) + call ie_addimage (ie, Memc[imname], imlist) + else + call ie_display (ie, Memc[imname], IE_DFRAME(ie)/100) + + case 'g': # Graphics cursor + curtype = 'g' + case 'i': # Image cursor + curtype = 'i' + case 'm': # Image statistics + call ie_statistics (ie, x, y) + + case 'n': # Next frame + if (IE_LIST(ie) != NULL) { + IE_INDEX(ie) = IE_INDEX(ie) + 1 + if (IE_INDEX(ie) > IE_LISTLEN(ie)) + IE_INDEX(ie) = 1 + } else { + IE_NEWFRAME(ie) = 100 * (IE_NEWFRAME(ie)/100 + 1) + 1 + if (IE_NEWFRAME(ie)/100 > IE_NFRAMES(ie)) + IE_NEWFRAME(ie) = 101 + } + im = ie_gimage (ie, YES) + + case 'o': # Overplot + mode = APPEND + + case 'p': # Previous frame + if (IE_LIST(ie) != NULL) { + IE_INDEX(ie) = IE_INDEX(ie) - 1 + if (IE_INDEX(ie) <= 0) + IE_INDEX(ie) = IE_LISTLEN(ie) + } else { + IE_NEWFRAME(ie) = 100 * (IE_NEWFRAME(ie)/100 - 1) + 1 + if (IE_NEWFRAME(ie)/100 <= 0) + IE_NEWFRAME(ie) = 100 * IE_NFRAMES(ie) + 1 + } + im = ie_gimage (ie, YES) + + case 'q': # Quit + break + + case 't': # Extract a section. + call ie_timexam (ie, x, y) + + case 'w': # Toggle logfile + if (IE_LOGFD(ie) == NULL) { + if (IE_LOGFILE(ie) == EOS) + call printf ("No log file defined\n") + else { + iferr (call ie_openlog (ie)) + call erract (EA_WARN) + } + } else { + call close (IE_LOGFD(ie)) + IE_LOGFD(ie) = NULL + call printf ("Logfile %s closed\n") + call pargstr (IE_LOGFILE(ie)) + } + + case 'x', 'y': # Positions + call ie_pos (ie, x, y, key) + case 'z': # Print grid + call ie_print (ie, x, y) + case 'I': # Immediate interrupt + call fatal (1, "Interrupt") + default: # Unrecognized command + call printf ("\007") + } + + switch (key) { + case '?', 'a', 'b', 'd', 'm', 'w', 'x', 'y', 'z', ',': + IE_LASTKEY(ie) = key + } + + # Draw or overplot a graph. + if (redraw == YES) { + switch (IE_GTYPE(ie)) { + case 'c': # column plot + call ie_cimexam (gp, mode, ie, x) + case 'e': # contour plot + call ie_eimexam (gp, mode, ie, x, y) + case 'h': # histogram plot + call ie_himexam (gp, mode, ie, x, y) + case 'j': # line plot + call ie_jimexam (gp, mode, ie, x, y, 1) + case 'k': # line plot + call ie_jimexam (gp, mode, ie, x, y, 2) + case 'l': # line plot + call ie_limexam (gp, mode, ie, y) + case 'r': # radial profile plot + call ie_rimexam (gp, mode, ie, x, y) + case 's': # surface plot + call ie_simexam (gp, mode, ie, x, y) + case 'u', 'v': # vector cut plot + call ie_vimexam (gp, mode, ie, x, y, IE_GTYPE(ie)) + case '.': # radial profile plot + call ie_qrimexam (gp, mode, ie, x, y) + } + redraw = NO + mode = NEW_FILE + } + } + + # Finish up. + call gclose (gp) + if (IE_IM(ie) != NULL && IE_IM(ie) != IE_DS(ie)) + call imunmap (IE_IM(ie)) + if (IE_MW(ie) != NULL) + call mw_close (IE_MW(ie)) + if (IE_PP(ie) != NULL) + call clcpset (IE_PP(ie)) + if (IE_DS(ie) != NULL) + call imunmap (IE_DS(ie)) + if (IE_LOGFD(ie) != NULL) + call close (IE_LOGFD(ie)) + if (IE_LIST(ie) != NULL) + call imtclose (IE_LIST(ie)) + call sfree (sp) +end + + +# IE_ADDIMAGE -- Add an image to the image list if not already present in +# the list, and display the image. + +procedure ie_addimage (ie, image, imlist) + +pointer ie #I imexamine descriptor +char image[ARB] #I image name +pointer imlist #I image list + +int i +bool inlist +pointer im, sp, lname +pointer ie_gimage(), imtopen() +int imtrgetim(), imtlen() +bool streq() + +begin + call smark (sp) + call salloc (lname, SZ_FNAME, TY_CHAR) + + # Is image already in list? + inlist = false + do i = 1, IE_LISTLEN(ie) { + if (imtrgetim (IE_LIST(ie), i, Memc[lname], SZ_FNAME) > 0) + if (streq (Memc[lname], image)) { + inlist = true + IE_INDEX(ie) = i + break + } + } + + # Add to list if missing. + if (!inlist) { + call strcat (",", Memc[imlist], SZ_IMLIST) + call strcat (image, Memc[imlist], SZ_IMLIST) + call imtclose (IE_LIST(ie)) + IE_LIST(ie) = imtopen (Memc[imlist]) + IE_LISTLEN(ie) = imtlen (IE_LIST(ie)) + IE_INDEX(ie) = IE_LISTLEN(ie) + } + + # Display the image. + im = ie_gimage (ie, YES) + call sfree (sp) +end diff --git a/pkg/images/tv/imexamine/x_imexam.x b/pkg/images/tv/imexamine/x_imexam.x new file mode 100644 index 00000000..100a6756 --- /dev/null +++ b/pkg/images/tv/imexamine/x_imexam.x @@ -0,0 +1 @@ +task imexamine = t_imexamine diff --git a/pkg/images/tv/jimexam.par b/pkg/images/tv/jimexam.par new file mode 100644 index 00000000..96acb75a --- /dev/null +++ b/pkg/images/tv/jimexam.par @@ -0,0 +1,29 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"wcslabel",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" + +naverage,i,h,5,1,,"Number of liness or columns to average" +center,b,h,yes,,,"Solve for center?" +background,b,h,yes,,,"Solve for background?" +sigma,r,h,1.,0.1,,"Initial sigma (pixels)" +width,r,h,10.,1.,,Background width (pixels) +xorder,i,h,0,0,2,Background terms to fit (0=median) + +rplot,r,h,10.,1.,,"Plotting radius (pixels)" +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,yes,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/kimexam.par b/pkg/images/tv/kimexam.par new file mode 100644 index 00000000..96acb75a --- /dev/null +++ b/pkg/images/tv/kimexam.par @@ -0,0 +1,29 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"wcslabel",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" + +naverage,i,h,5,1,,"Number of liness or columns to average" +center,b,h,yes,,,"Solve for center?" +background,b,h,yes,,,"Solve for background?" +sigma,r,h,1.,0.1,,"Initial sigma (pixels)" +width,r,h,10.,1.,,Background width (pixels) +xorder,i,h,0,0,2,Background terms to fit (0=median) + +rplot,r,h,10.,1.,,"Plotting radius (pixels)" +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,yes,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/limexam.par b/pkg/images/tv/limexam.par new file mode 100644 index 00000000..bdec3493 --- /dev/null +++ b/pkg/images/tv/limexam.par @@ -0,0 +1,22 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"wcslabel",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" + +naverage,i,h,1,,,Number of lines to average +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,no,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/mkpkg b/pkg/images/tv/mkpkg new file mode 100644 index 00000000..3ad9be17 --- /dev/null +++ b/pkg/images/tv/mkpkg @@ -0,0 +1,37 @@ +# TV package. + +$call relink +$exit + +update: + $ifeq (USE_IIS, yes) @iis $endif + $call relink + $call install + ; + +relink: + $set LIBS1 = "-liminterp -lncar -lgks -lds -lxtools" + $set LIBS2 = "-lgsurfit -lnlfit -lcurfit -lllsq -liminterp" + $checkout libds.a lib$ + $update libds.a + $checkin libds.a lib$ + $update libpkg.a + $omake x_tv.x + $link x_tv.o libpkg.a $(LIBS1) $(LIBS2) -o xx_tv.e + ; + +install: + $move xx_tv.e bin$x_tv.e + ; + +libds.a: + @display + @wcslab + ; + +libpkg.a: + @imedit + @imexamine + @tvmark + @wcslab + ; diff --git a/pkg/images/tv/rimexam.par b/pkg/images/tv/rimexam.par new file mode 100644 index 00000000..c2dddf15 --- /dev/null +++ b/pkg/images/tv/rimexam.par @@ -0,0 +1,35 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"Radius",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" +fitplot,b,h,yes,,,"Overplot profile fit?" +fittype,s,h,"moffat","gaussian|moffat",,"Profile type to fit" + +center,b,h,yes,,,"Center object in aperture?" +background,b,h,yes,,,"Fit and subtract background?" +radius,r,h,5.,1.,,"Object radius" +buffer,r,h,5.,0.,,Background buffer width +width,r,h,5.,1.,,Background width +iterations,i,h,3,1,,"Number of radius adjustment iterations" +xorder,i,h,0,0,,Background x order +yorder,i,h,0,0,,Background y order +magzero,r,h,25.,,,Magnitude zero point +beta,r,h,INDEF,,,Moffat beta parameter + +rplot,r,h,8.,1.,,"Plotting radius" +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,yes,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/simexam.par b/pkg/images/tv/simexam.par new file mode 100644 index 00000000..ccdde3bc --- /dev/null +++ b/pkg/images/tv/simexam.par @@ -0,0 +1,10 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +axes,b,h,yes,,,Draw axes? + +ncolumns,i,h,21,2,,"Number of columns" +nlines,i,h,21,2,,"Number of lines" +angh,r,h, -33.,,,Horizontal viewing angle (degrees) +angv,r,h,25.,,,Vertical viewing angle (degrees) +floor,r,h,INDEF,,,Minimum value to be plotted +ceiling,r,h,INDEF,,,Maximum value to be plotted diff --git a/pkg/images/tv/tv.cl b/pkg/images/tv/tv.cl new file mode 100644 index 00000000..b136fff5 --- /dev/null +++ b/pkg/images/tv/tv.cl @@ -0,0 +1,43 @@ +#{ TV -- Image Display Control package. + +set tv = "images$tv/" +set iis = "tv$iis/" + +package tv + +set imedit_help = "tv$imedit/imedit.key" + +# Tasks. + +task _dcontrol, + display, + imedit, + imexamine, + tvmark, + wcslab = "tv$x_tv.e" + +task bpmedit = "tv$imedit/bpmedit.cl" + +# Sub-packages. + +task iis.pkg = "iis$iis.cl" + +# Imexamine psets. + +task cimexam = tv$cimexam.par; hidetask cimexam +task eimexam = tv$eimexam.par; hidetask eimexam +task himexam = tv$himexam.par; hidetask himexam +task jimexam = tv$jimexam.par; hidetask jimexam +task kimexam = tv$kimexam.par; hidetask kimexam +task limexam = tv$limexam.par; hidetask limexam +task rimexam = tv$rimexam.par; hidetask rimexam +task simexam = tv$simexam.par; hidetask simexam +task vimexam = tv$vimexam.par; hidetask vimexam + +# Wcslab psets. + +task wcspars = tv$wcspars.par; hidetask wcspars +task wlpars = tv$wlpars.par; hidetask wlpars + + +clbye() diff --git a/pkg/images/tv/tv.hd b/pkg/images/tv/tv.hd new file mode 100644 index 00000000..d04a92f2 --- /dev/null +++ b/pkg/images/tv/tv.hd @@ -0,0 +1,23 @@ +# Help directory for the TV package + +$doc = "images$tv/doc/" +$display = "images$tv/display/" +$imedit = "images$tv/imedit/" +$imexamine = "images$tv/imexamine/" +$tvmark = "images$tv/tvmark/" +$wcslab = "images$tv/wcslab/" +$iis = "images$tv/iis/" + +_dcontrol hlp=doc$dcontrol.hlp, sys=.. +bpmedit hlp=doc$bpmedit.hlp, src=imedit$bpmedit.cl +display hlp=doc$display.hlp, src=display$t_display.x +imedit hlp=doc$imedit.hlp, src=imedit$t_imedit.x +imexamine hlp=doc$imexamine.hlp, src=imexamine$t_imexam.x +tvmark hlp=doc$tvmark.hlp, src=tvmark$t_tvmark.x +wcslab hlp=doc$wcslab.hlp, src=wcslab$t_wcslab.x +revisions sys=Revisions + +iis men=iis$iis.men, + hlp=.., + src=iis$iis.cl, + pkg=iis$iis.hd diff --git a/pkg/images/tv/tv.men b/pkg/images/tv/tv.men new file mode 100644 index 00000000..3485447f --- /dev/null +++ b/pkg/images/tv/tv.men @@ -0,0 +1,7 @@ + bpmedit - examine and edit bad pixel masks associated with images + display - Load an image or image section into the display + iis - IIS image display control package + imedit - Examine and edit pixels in images + imexamine - Examine images using image display, graphics, and text + tvmark - Mark objects on the image display + wcslab - Overlay a displayed image with a world coordinate grid diff --git a/pkg/images/tv/tv.par b/pkg/images/tv/tv.par new file mode 100644 index 00000000..db706f09 --- /dev/null +++ b/pkg/images/tv/tv.par @@ -0,0 +1 @@ +version,s,h,"Apr91" diff --git a/pkg/images/tv/tvmark.par b/pkg/images/tv/tvmark.par new file mode 100644 index 00000000..28d69fd0 --- /dev/null +++ b/pkg/images/tv/tvmark.par @@ -0,0 +1,23 @@ +# TVMARK + +frame,i,a,1,,,Default frame number for display +coords,f,a,,,,Input coordinate list +logfile,f,h,"",,,Output log file +autolog,b,h,no,,,Automatically log each marking command +outimage,f,h,"",,,Output snapped image +deletions,f,h,"",,,Output coordinate deletions list +commands,*imcur,h,"",,,"Image cursor: [x y wcs] key [cmd]" +mark,s,h,"point","point|circle|rectangle|line|plus|cross|none",,The mark type +radii,s,h,"0",,,Radii in image pixels of concentric circles +lengths,s,h,"0",,,Lengths and width in image pixels of concentric rectangles +font,s,h,"raster",,,Default font +color,i,h,255,,,Gray level of marks to be drawn +label,b,h,no,,,Label the marked coordinates +number,b,h,no,,,Number the marked coordinates +nxoffset,i,h,0,,,X offset in display pixels of number +nyoffset,i,h,0,,,Y offset in display pixels of number +pointsize,i,h,3,,,Size of mark type point in display pixels +txsize,i,h,1,,,Size of text and numbers in font units +tolerance,r,h,1.5,,,Tolerance for deleting coordinates in image pixels +interactive,b,h,no,,,Mode of use +mode,s,h,'ql' diff --git a/pkg/images/tv/tvmark/asciilook.inc b/pkg/images/tv/tvmark/asciilook.inc new file mode 100644 index 00000000..68974d34 --- /dev/null +++ b/pkg/images/tv/tvmark/asciilook.inc @@ -0,0 +1,19 @@ +data (asciilook[i], i=1,7) / 449, 449, 449, 449, 449, 449, 449 / +data (asciilook[i], i=8,14) / 449, 449, 449, 449, 449, 449, 449 / +data (asciilook[i], i=15,21) / 449, 449, 449, 449, 449, 449, 449 / +data (asciilook[i], i=22,28) / 449, 449, 449, 449, 449, 449, 449 / +data (asciilook[i], i=29,35) / 449, 449, 449, 449, 001, 008, 015 / +data (asciilook[i], i=36,42) / 022, 029, 036, 043, 050, 057, 064 / +data (asciilook[i], i=43,49) / 071, 078, 085, 092, 099, 106, 113 / +data (asciilook[i], i=50,56) / 120, 127, 134, 141, 148, 155, 162 / +data (asciilook[i], i=57,63) / 169, 176, 183, 190, 197, 204, 211 / +data (asciilook[i], i=64,70) / 218, 225, 232, 239, 246, 253, 260 / +data (asciilook[i], i=71,77) / 267, 274, 281, 288, 295, 302, 309 / +data (asciilook[i], i=78,84) / 316, 323, 330, 337, 344, 351, 358 / +data (asciilook[i], i=85,91) / 365, 372, 379, 386, 393, 400, 407 / +data (asciilook[i], i=92,98) / 414, 421, 428, 435, 442, 449, 232 / +data (asciilook[i], i=99,105) / 239, 246, 253, 260, 267, 274, 281 / +data (asciilook[i], i=106,112) / 288, 295, 302, 309, 316, 323, 330 / +data (asciilook[i], i=113,119) / 337, 344, 351, 358, 365, 372, 379 / +data (asciilook[i], i=120,126) / 386, 393, 400, 407, 449, 449, 449 / +data (asciilook[i], i=127,128) / 449, 449/ diff --git a/pkg/images/tv/tvmark/mkbmark.x b/pkg/images/tv/tvmark/mkbmark.x new file mode 100644 index 00000000..5ece5d4a --- /dev/null +++ b/pkg/images/tv/tvmark/mkbmark.x @@ -0,0 +1,561 @@ +include +include "tvmark.h" + +# MK_BMARK -- Procedure to mark symbols in the frame buffer given a coordinate +# list and a mark type. + +procedure mk_bmark (mk, im, iw, cl, ltid, fnt) + +pointer mk # pointer to the mark structure +pointer im # frame image descriptor +pointer iw # pointer to the wcs structure +int cl # coordinate file descriptor +int ltid # current number in the list +int fnt # font file descriptor + +int ncols, nlines, nr, nc, x1, x2, y1, y2 +pointer sp, str, lengths, radii, label +real x, y, fx, fy, ofx, ofy, xmag, ymag, lmax, lratio, rmax, ratio +int fscan(), nscan(), mk_stati(), itoc() +int mk_plimits(), mk_llimits(), mk_rlimits(), mk_climits() +pointer mk_statp() +real mk_statr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (label, SZ_LINE, TY_CHAR) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Get the magnification factors. + call mk_mag (im, iw, xmag, ymag) + + # Define the rectangles in terms of device coordinates. + if (mk_stati (mk, MKTYPE) == MK_RECTANGLE) { + nr = mk_stati (mk, NRECTANGLES) + call salloc (lengths, nr, TY_REAL) + if (xmag <= 0.0) { + lmax = 0.0 + call amovkr (0.0, Memr[lengths], nr) + } else { + call adivkr (Memr[mk_statp(mk,RLENGTHS)], xmag, Memr[lengths], + nr) + lmax = Memr[lengths+nr-1] + } + if (ymag <= 0.) + lratio = 0.0 + else + lratio = mk_statr (mk, RATIO) * xmag / ymag + } + + # Define the circles in terms of device coordinates. + if (mk_stati (mk, MKTYPE) == MK_CIRCLE) { + nc = mk_stati (mk, NCIRCLES) + call salloc (radii, nc, TY_REAL) + if (xmag <= 0) { + rmax = 0.0 + call amovkr (0.0, Memr[radii], nc) + } else { + call adivkr (Memr[mk_statp(mk,RADII)], xmag, Memr[radii], nc) + rmax = Memr[radii+nc-1] + } + if (ymag <= 0.0) + ratio = 0.0 + else + ratio = xmag / ymag + } + + # Run through the coordinate list sequentially plotting the + # points, circles or rectangles. Speed it up later by reading + # all the points in first, sorting and accessing the frame + # buffer sequentially instead of randomly. + + ofx = INDEFR + ofy = INDEFR + while (fscan (cl) != EOF) { + + # Get the x and y coords (possibly add an id number later). + call gargr (x) + call gargr (y) + if (nscan() < 2) + next + if (IS_INDEFR(x) || IS_INDEFR(y)) + next + call gargwrd (Memc[label], SZ_LINE) + call iw_im2fb (iw, x, y, fx, fy) + + switch (mk_stati (mk, MKTYPE)) { + + case MK_POINT: + if (mk_plimits (fx, fy, mk_stati (mk, SZPOINT), + ncols, nlines, x1, x2, y1, y2) == YES) + call mk_drawpt (im, x1, x2, y1, y2, mk_stati (mk, + GRAYLEVEL)) + + case MK_LINE: + if (! IS_INDEFR(ofx) && ! IS_INDEFR(ofy)) { + if (mk_llimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, + y1, y2) == YES) + call mk_drawline (im, ofx, ofy, fx, fy, x1, x2, y1, y2, + mk_stati (mk, GRAYLEVEL)) + } + + case MK_RECTANGLE: + if (mk_rlimits (fx, fy, lmax, lratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawbox (im, fx, fy, x1, x2, y1, y2, Memr[lengths], + lratio, nr, mk_stati (mk, GRAYLEVEL)) + } + + case MK_CIRCLE: + if (mk_climits (fx, fy, rmax, ratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawcircles (im, fx, fy, x1, x2, y1, y2, + Memr[radii], ratio, nc, mk_stati (mk, + GRAYLEVEL)) + call imflush (im) + } + + case MK_PLUS: + call mk_textim (im, "+", nint (fx), nint (fy), mk_stati (mk, + SIZE), mk_stati (mk, SIZE), mk_stati (mk, GRAYLEVEL), YES) + call imflush (im) + + case MK_CROSS: + call mk_textim (im, "x", nint (fx), nint (fy), mk_stati (mk, + SIZE), mk_stati (mk, SIZE), mk_stati (mk, GRAYLEVEL), YES) + call imflush (im) + + default: + } + + # Number the text file. + ltid = ltid + 1 + if (mk_stati (mk, LABEL) == YES) { + if (Memc[label] != EOS) { + call mk_textim (im, Memc[label], nint (fx) + + mk_stati(mk, NXOFFSET), nint (fy) + mk_stati (mk, + NYOFFSET), mk_stati (mk, SIZE), mk_stati (mk, SIZE), + mk_stati (mk, GRAYLEVEL), NO) + call imflush (im) + } + } else if (mk_stati (mk, NUMBER) == YES) { + if (itoc (ltid, Memc[str], SZ_FNAME) > 0) { + call mk_textim (im, Memc[str], nint (fx) + + mk_stati(mk, NXOFFSET), nint (fy) + mk_stati (mk, + NYOFFSET), mk_stati (mk, SIZE), mk_stati (mk, SIZE), + mk_stati (mk, GRAYLEVEL), NO) + call imflush (im) + } + } + + ofx = fx + ofy = fy + } + + call imflush (im) + call sfree (sp) +end + + +# MK_DRAWPT -- Procedure to draw a point into the frame buffer. + +procedure mk_drawpt (im, x1, x2, y1, y2, graylevel) + +pointer im # pointer to the frame image +int x1, x2 # column limits +int y1, y2 # line limits +int graylevel # color of dot to be marked + +int i, npix +pointer vp +pointer imps2s() + +begin + npix = (x2 - x1 + 1) * (y2 - y1 + 1) + vp = imps2s (im, x1, x2, y1, y2) + do i = 1, npix + Mems[vp+i-1] = graylevel +end + + +# MK_PLIMITS -- Compute the extent of a dot. + +int procedure mk_plimits (fx, fy, szdot, ncols, nlines, x1, x2, y1, y2) + +real fx, fy # frame buffer coordinates of point +int szdot # size of a dot +int ncols, nlines # dimensions of the frame buffer +int x1, x2 # column limits +int y1, y2 # line limits + +begin + x1 = nint (fx) - szdot + x2 = x1 + 2 * szdot + if (x1 > ncols || x2 < 1) + return (NO) + x1 = max (1, min (ncols, x1)) + x2 = min (ncols, max (1, x2)) + + y1 = nint (fy) - szdot + y2 = y1 + 2 * szdot + if (y1 > nlines || y2 < 1) + return (NO) + y1 = max (1, min (nlines, y1)) + y2 = min (nlines, max (1, y2)) + + return (YES) +end + + +# MK_DRAWLINE -- Procedure to draw lines. + +procedure mk_drawline (im, ofx, ofy, fx, fy, x1, x2, y1, y2, graylevel) + +pointer im # pointer to the frame buffer image +real ofx, ofy # previous coordinates +real fx, fy # current coordinates +int x1, x2 # column limits +int y1, y2 # line limits +int graylevel # picture gray level + +int i, j, ix1, ix2, npix, itemp +pointer vp +real m, b +pointer imps2s() + +begin + # Compute the slope and intercept. + if (x2 == x1) { + vp = imps2s (im, x1, x2, y1, y2) + npix = y2 - y1 + 1 + do i = 1, npix + Mems[vp+i-1] = graylevel + } else if (y2 == y1) { + vp = imps2s (im, x1, x2, y1, y2) + npix = x2 - x1 + 1 + do i = 1, npix + Mems[vp+i-1] = graylevel + } else { + m = (fy - ofy ) / (fx - ofx) + b = ofy - m * ofx + #if (m > 0.0) + #b = y1 - m * x1 + #else + #b = y2 - m * x1 + do i = y1, y2 { + if (i == y1) { + ix1 = nint ((i - b) / m) + ix2 = nint ((i + 0.5 - b) / m) + } else if (i == y2) { + ix1 = nint ((i - 0.5 - b) / m) + ix2 = nint ((i - b) / m) + } else { + ix1 = nint ((i - 0.5 - b) / m) + ix2 = nint ((i + 0.5 - b) / m) + } + itemp = min (ix1, ix2) + ix2 = max (ix1, ix2) + ix1 = itemp + if (ix1 < x1 || ix2 > x2) + next + vp = imps2s (im, ix1, ix2, i, i) + npix = ix2 - ix1 + 1 + do j = 1, npix + Mems[vp+j-1] = graylevel + } + } +end + + +# MK_LLIMITS -- Compute the limits of a line segment. + +int procedure mk_llimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, y1, y2) + +real ofx, ofy # previous coordinates +real fx, fy # current coordinates +int ncols, nlines # number of lines +int x1, x2 # column limits +int y1, y2 # line limits + +begin + x1 = nint (min (ofx, fx)) + x2 = nint (max (ofx, fx)) + if (x2 < 1 || x1 > ncols) + return (NO) + x1 = max (1, min (ncols, x1)) + x2 = min (ncols, max (1, x2)) + + y1 = nint (min (ofy, fy)) + y2 = nint (max (ofy, fy)) + if (y2 < 1 || y1 > nlines) + return (NO) + y1 = max (1, min (nlines, y1)) + y2 = min (nlines, max (1, y2)) + + return (YES) +end + + +# MK_DRAWCIRCLES -- Draw concentric circles around a point. + +procedure mk_drawcircles (im, fx, fy, x1, x2, y1, y2, cradii, ratio, ncircles, + graylevel) + +pointer im # pointer to frame buffer image +real fx, fy # center of circle +int x1, x2 # column limits +int y1, y2 # line limits +real cradii[ARB] # sorted list of radii +real ratio # ratio of the magnifications +int ncircles # number of circles +int graylevel # gray level for marking + +int i, j, k, ix1, ix2, npix +pointer ovp +real dy2, dym, dyp, r2, dx1, dx2 +pointer imps2s() + +begin + if (ratio <= 0) + return + + npix = x2 - x1 + 1 + + do i = y1, y2 { + + dy2 = (i - fy) ** 2 + if (i >= fy) { + dym = ((i - .5 - fy) / ratio) ** 2 + dyp = ((i + .5 - fy) / ratio) ** 2 + } else { + dyp = ((i - .5 - fy) / ratio) ** 2 + dym = ((i + .5 - fy) / ratio) ** 2 + } + + do j = 1, ncircles { + + r2 = cradii[j] ** 2 + if (r2 < dym ) + next + + dx1 = r2 - dym + if (dx1 >= 0.0) + dx1 = sqrt (dx1) + else + dx1 = 0.0 + dx2 = r2 - dyp + if (dx2 >= 0.0) + dx2 = sqrt (dx2) + else + dx2 = 0.0 + + ix1 = nint (fx - dx1) + ix2 = nint (fx - dx2) + if (ix1 <= IM_LEN(im,1) && ix2 >= 1) { + ix1 = max (1, ix1) + ix2 = min (ix2, IM_LEN(im,1)) + ovp = imps2s (im, ix1, ix2, i, i) + do k = 1, ix2 - ix1 + 1 + Mems[ovp+k-1] = graylevel + } + + ix1 = nint (fx + dx1) + ix2 = nint (fx + dx2) + if (ix2 <= IM_LEN(im,1) && ix1 >= 1) { + ix2 = max (1, ix2) + ix1 = min (ix1, IM_LEN(im,1)) + ovp = imps2s (im, ix2, ix1, i, i) + do k = 1, ix2 - ix1 + 1 + Mems[ovp+k-1] = graylevel + } + } + } + +end + + +# MK_CLIMITS -- Compute the extent of a circle. + +int procedure mk_climits (fx, fy, rmax, ratio, ncols, nlines, x1, x2, y1, y2) + +real fx, fy # center of rectangle +real rmax # maximum half length of box +real ratio # ratio of the magnifications +int ncols, nlines # dimension of the image +int x1, x2 # column limits +int y1, y2 # line limits + +begin + x1 = nint (fx - rmax) + x2 = nint (fx + rmax) + if (x1 > ncols || x2 < 1) + return (NO) + x1 = max (1, min (ncols, x1)) + x2 = min (ncols, max (1, x2)) + + y1 = nint (fy - rmax * ratio) + y2 = nint (fy + rmax * ratio) + if (y1 > nlines || y2 < 1) + return (NO) + y1 = max (1, min (nlines, y1)) + y2 = min (nlines, max (1, y2)) + + return (YES) +end + + +# MK_DRAWBOX -- Procedure to draw a box into the frame buffer. + +procedure mk_drawbox (im, fx, fy, x1, x2, y1, y2, length, ratio, nbox, + graylevel) + +pointer im # pointer to frame buffer image +real fx, fy # center of rectangle +int x1, x2 # column limits +int y1, y2 # line limits +real length[ARB] # list of rectangle lengths +real ratio # ratio of width/length +int nbox # number of boxes +int graylevel # value of graylevel + +int i, j, k, npix, ydist, bdist, ix1, ix2 +pointer ovp +real hlength +pointer imps2s() + +begin + if (x1 == x2) { + ovp = imps2s (im, x1, x2, y1, y2) + npix = y2 - y1 + 1 + do i = 1, npix + Mems[ovp+i-1] = graylevel + } else if (y1 == y2) { + ovp = imps2s (im, x1, x2, y1, y2) + npix = x2 - x1 + 1 + do i = 1, npix + Mems[ovp+i-1] = graylevel + } else { + npix = x2 - x1 + 1 + do i = y1, y2 { + ydist = nint (abs (i - fy)) + do j = 1, nbox { + hlength = length[j] / 2.0 + bdist = nint (hlength * ratio) + if (ydist > bdist) + next + ix1 = max (x1, nint (fx - hlength)) + ix2 = min (x2, nint (fx + hlength)) + if (ix1 < 1 || ix1 > IM_LEN(im,1) || ix2 < 1 || + ix2 > IM_LEN(im,1)) + next + if (ydist == bdist) { + ovp = imps2s (im, ix1, ix2, i, i) + do k = 1, ix2 - ix1 + 1 + Mems[ovp+k-1] = graylevel + } else { + ovp = imps2s (im, ix1, ix1, i, i) + Mems[ovp] = graylevel + ovp = imps2s (im, ix2, ix2, i, i) + Mems[ovp] = graylevel + } + } + } + } +end + + +# MK_RLIMITS -- Compute the extent of a rectangle. + +int procedure mk_rlimits (fx, fy, lmax, lratio, ncols, nlines, x1, x2, y1, y2) + +real fx, fy # center of rectangle +real lmax # maximum half length of box +real lratio # ratio of width to length +int ncols, nlines # dimension of the image +int x1, x2 # column limits +int y1, y2 # line limits + +real hlmax, wmax + +begin + hlmax = lmax / 2.0 + wmax = lmax * lratio + + x1 = nint (fx - hlmax) + x2 = nint (fx + hlmax) + if (x1 > ncols || x2 < 1) + return (NO) + x1 = max (1, min (ncols, x1)) + x2 = min (ncols, max (1, x2)) + + y1 = fy - wmax + y2 = fy + wmax + if (y1 > nlines || y2 < 1) + return (NO) + y1 = max (1, min (nlines, y1)) + y2 = min (nlines, max (1, y2)) + + return (YES) +end + + +# MK_PBOX -- Plot a box + +procedure mk_pbox (im, x1, x2, y1, y2, graylevel) + +pointer im # pointer to the image +int x1, x2 # column limits +int y1, y2 # line limits +int graylevel # line value + +int i, j, npix +pointer ovp +pointer imps2s() + +begin + do i = y1, y2 { + if (i == y1) { + npix = x2 - x1 + 1 + ovp = imps2s (im, x1, x2, i, i) + do j = 1, npix + Mems[ovp+j-1] = graylevel + } else if (i == y2) { + npix = x2 - x1 + 1 + ovp = imps2s (im, x1, x2, i, i) + do j = 1, npix + Mems[ovp+j-1] = graylevel + } else { + ovp = imps2s (im, x1, x1, i, i) + Mems[ovp] = graylevel + ovp = imps2s (im, x2, x2, i, i) + Mems[ovp] = graylevel + } + } +end + + +# MK_BLIMITS -- Procedure to compute the boundary limits for drawing +# a box. + +procedure mk_blimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, y1, y2) + +real ofx, ofy # first point +real fx, fy # second point +int ncols, nlines # dimensions of the image +int x1, x2 # column limits +int y1, y2 # line limits + +begin + x1 = nint (min (ofx, fx)) + x1 = max (1, min (x1, ncols)) + x2 = nint (max (ofx, fx)) + x2 = min (ncols, max (x2, 1)) + + y1 = nint (min (ofy, fy)) + y1 = max (1, min (y1, nlines)) + y2 = nint (max (ofy, fy)) + y2 = min (nlines, max (y2, 1)) +end diff --git a/pkg/images/tv/tvmark/mkcolon.x b/pkg/images/tv/tvmark/mkcolon.x new file mode 100644 index 00000000..e4dfe01a --- /dev/null +++ b/pkg/images/tv/tvmark/mkcolon.x @@ -0,0 +1,394 @@ +include +include +include +include "tvmark.h" + +# MK_COLON -- Procedure to process immark colon commands. + +procedure mk_colon (mk, cmdstr, im, iw, sim, log, cl, ltid, dl) + +pointer mk # pointer to the immark structure +char cmdstr[ARB] # command string +pointer im # pointer to the frame buffer +pointer iw # pointer to the wcs information +pointer sim # pointer to a scratch image +int log # log file descriptor +int cl # coords file descriptor +int ltid # coords file sequence number +int dl # deletions file descriptor + +bool bval +real rval +pointer sp, cmd, str, outim, deletions, ext +int ncmd, mark, font, ival, ip, nchars, wcs_status + +real mk_statr() +bool itob(), streq() +pointer immap(), imd_mapframe(), iw_open() +int open(), strdic(), nscan(), mk_stati(), btoi(), ctowrd() +errchk imd_mapframe(), iw_open(), immap(), imunmap(), open() + +begin + # Allocate some working memory. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (deletions, SZ_FNAME, TY_CHAR) + call salloc (ext, SZ_FNAME, TY_CHAR) + + # Get the command. + ip = 1 + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return + } + + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, MKCMDS) + switch (ncmd) { + case MKCMD_IMAGE: + + case MKCMD_OUTIMAGE: + call gargstr (Memc[cmd], SZ_LINE) + call mk_stats (mk, OUTIMAGE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_OUTIMAGE) + call pargstr (Memc[str]) + } else { + nchars = ctowrd (Memc[cmd], ip, Memc[str], SZ_LINE) + call mk_sets (mk, OUTIMAGE, Memc[str]) + } + + case MKCMD_DELETIONS: + call gargstr (Memc[cmd], SZ_LINE) + call mk_stats (mk, DELETIONS, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_DELETIONS) + call pargstr (Memc[str]) + } else { + nchars = ctowrd (Memc[cmd], ip, Memc[str], SZ_LINE) + call mk_sets (mk, DELETIONS, Memc[str]) + } + + case MKCMD_SNAP: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call mk_stats (mk, OUTIMAGE, Memc[str], SZ_FNAME) + if (Memc[str] == EOS) + call mk_stats (mk, IMAGE, Memc[str], SZ_FNAME) + call mk_imname (Memc[str], "", "snap", Memc[cmd], SZ_FNAME) + } + + iferr { + outim = immap (Memc[cmd], NEW_COPY, im) + call printf ("Creating image: %s - ") + call pargstr (Memc[cmd]) + call flush (STDOUT) + call mk_imcopy (im, outim) + call imunmap (outim) + } then { + call printf ("\n") + call erract (EA_WARN) + } else { + call printf ("done\n") + } + + case MKCMD_COORDS: + call gargstr (Memc[cmd], SZ_LINE) + call mk_stats (mk, COORDS, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_COORDS) + call pargstr (Memc[str]) + } else { + nchars = ctowrd (Memc[cmd], ip, Memc[str], SZ_LINE) + if (cl != NULL) { + call close( cl) + call close (dl) + cl = NULL + dl = NULL + } + iferr { + if (Memc[str] != EOS) { + iferr (cl = open (Memc[str], READ_WRITE, TEXT_FILE)) { + cl = open (Memc[str], NEW_FILE, TEXT_FILE) + call close (cl) + cl = open (Memc[str], READ_WRITE, TEXT_FILE) + call mk_stats (mk, DELETIONS, Memc[ext], SZ_FNAME) + call sprintf (Memc[deletions], SZ_FNAME, "%s.%s") + call pargstr (Memc[str]) + if (Memc[ext] == EOS) + call pargstr ("del") + else + call pargstr (Memc[ext]) + } + } + } then { + cl = NULL + dl = NULL + call erract (EA_WARN) + call mk_sets (mk, COORDS, "") + } else { + call mk_sets (mk, COORDS, Memc[str]) + } + ltid = 0 + } + + case MKCMD_LOGFILE: + call gargstr (Memc[cmd], SZ_LINE) + call mk_stats (mk, LOGFILE, Memc[str], SZ_FNAME) + if (Memc[cmd] == EOS || streq (Memc[cmd], Memc[str])) { + call printf ("%s: %s\n") + call pargstr (KY_LOGFILE) + call pargstr (Memc[str]) + } else { + nchars = ctowrd (Memc[cmd], ip, Memc[str], SZ_LINE) + if (log != NULL) { + call close (log) + log = NULL + } + iferr { + if (Memc[str] != EOS) + log = open (Memc[str], NEW_FILE, TEXT_FILE) + } then { + log = NULL + call erract (EA_WARN) + call mk_sets (mk, LOGFILE, "") + call printf ("Log file is undefined.\n") + } else + call mk_sets (mk, LOGFILE, Memc[str]) + } + + case MKCMD_AUTOLOG: + call gargb (bval) + if (nscan () == 1) { + call printf ("%s = %b\n") + call pargstr (KY_AUTOLOG) + call pargb (itob (mk_stati (mk, AUTOLOG))) + } else + call mk_seti (mk, AUTOLOG, btoi (bval)) + + case MKCMD_FRAME: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %g\n") + call pargstr (KY_FRAME) + call pargi (mk_stati (mk, FRAME)) + } else if (ival != mk_stati (mk, FRAME)) { + call iw_close (iw) + call imunmap (im) + iferr { + im = imd_mapframe (ival, READ_WRITE, YES) + iw = iw_open (im, ival, Memc[str], SZ_FNAME, wcs_status) + call mk_sets (mk, IMAGE, Memc[str]) + } then { + call erract (EA_WARN) + im = imd_mapframe (mk_stati(mk,FRAME), READ_WRITE, YES) + iw = iw_open (im, mk_stati(mk,FRAME), + Memc[str], SZ_FNAME, wcs_status) + call mk_sets (mk, IMAGE, Memc[str]) + } else + call mk_seti (mk, FRAME, ival) + } + + case MKCMD_FONT: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call mk_stats (mk, FONT, Memc[cmd], SZ_LINE) + call printf ("%s = %s\n") + call pargstr (KY_FONT) + call pargstr (Memc[cmd]) + } else { + font = strdic (Memc[cmd], Memc[cmd], SZ_LINE, MKFONTLIST) + if (font > 0) + call mk_sets (mk, FONT, Memc[cmd]) + } + + case MKCMD_LABEL: + call gargb (bval) + if (nscan () == 1) { + call printf ("%s = %b\n") + call pargstr (KY_LABEL) + call pargb (itob (mk_stati (mk, LABEL))) + } else + call mk_seti (mk, LABEL, btoi (bval)) + + case MKCMD_NUMBER: + call gargb (bval) + if (nscan () == 1) { + call printf ("%s = %b\n") + call pargstr (KY_NUMBER) + call pargb (itob (mk_stati (mk, NUMBER))) + } else + call mk_seti (mk, NUMBER, btoi (bval)) + + case MKCMD_NXOFFSET: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %g\n") + call pargstr (KY_NXOFFSET) + call pargi (mk_stati (mk, NXOFFSET)) + } else + call mk_seti (mk, NXOFFSET, ival) + + case MKCMD_NYOFFSET: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %g\n") + call pargstr (KY_NYOFFSET) + call pargi (mk_stati (mk, NYOFFSET)) + } else + call mk_seti (mk, NYOFFSET, ival) + + case MKCMD_GRAYLEVEL: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %d\n") + call pargstr (KY_GRAYLEVEL) + call pargi (mk_stati (mk, GRAYLEVEL)) + } else + call mk_seti (mk, GRAYLEVEL, ival) + + case MKCMD_SZPOINT: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %d\n") + call pargstr (KY_SZPOINT) + call pargi (2 * mk_stati (mk, SZPOINT) + 1) + } else { + if (mod (ival, 2) == 0) + ival = ival + 1 + ival = ival / 2 + call mk_seti (mk, SZPOINT, ival) + } + + case MKCMD_SIZE: + call gargi (ival) + if (nscan () == 1) { + call printf ("%s = %d\n") + call pargstr (KY_SIZE) + call pargi (mk_stati (mk, SIZE)) + } else + call mk_seti (mk, SIZE, ival) + + case MKCMD_TOLERANCE: + call gargr (rval) + if (nscan () == 1) { + call printf ("%s = %g\n") + call pargstr (KY_TOLERANCE) + call pargr (mk_statr (mk, TOLERANCE)) + } else + call mk_setr (mk, TOLERANCE, rval) + + case MKCMD_MARK: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call mk_stats (mk, MARK, Memc[cmd], SZ_LINE) + call printf ("%s = %s\n") + call pargstr (KY_MARK) + call pargstr (Memc[cmd]) + } else { + mark = strdic (Memc[cmd], Memc[cmd], SZ_LINE, MKTYPELIST) + if (mark > 0) { + call mk_seti (mk, MKTYPE, mark) + call mk_sets (mk, MARK, Memc[cmd]) + } + } + + case MKCMD_CIRCLES: + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call mk_stats (mk, CSTRING, Memc[cmd], SZ_LINE) + call printf ("%s = %s %s\n") + call pargstr (KY_CIRCLES) + if (Memc[cmd] == EOS) + call pargstr ("0") + else + call pargstr (Memc[cmd]) + call pargstr ("pixels") + } else + call mk_sets (mk, CSTRING, Memc[cmd]) + + case MKCMD_RECTANGLES: + call gargwrd (Memc[cmd], SZ_LINE) + call gargr (rval) + if (Memc[cmd] == EOS) { + call mk_stats (mk, RSTRING, Memc[cmd], SZ_LINE) + call printf ("%s = %s %g\n") + call pargstr (KY_RECTANGLE) + if (Memc[cmd] == EOS) + call pargstr ("0") + else + call pargstr (Memc[cmd]) + call pargr (mk_statr (mk, RATIO)) + } else { + call mk_sets (mk, RSTRING, Memc[cmd]) + if (nscan () < 3) + call mk_setr (mk, RATIO, 1.0) + else + call mk_setr (mk, RATIO, rval) + } + + case MKCMD_SHOW: + call mk_show (mk) + + case MKCMD_SAVE: + iferr { + + # Check that the sizes agree. + if (sim == NULL) { + call mktemp ("scratch", Memc[cmd], SZ_FNAME) + sim = immap (Memc[cmd], NEW_COPY, im) + } else if (IM_LEN(im,1) != IM_LEN(sim,1) || IM_LEN(im,2) != + IM_LEN(sim,2)) { + call strcpy (IM_HDRFILE(sim), Memc[cmd], SZ_FNAME) + call imunmap (sim) + call imdelete (Memc[cmd]) + call mktemp ("scratch", Memc[cmd], SZ_FNAME) + sim = immap (Memc[cmd], NEW_COPY, im) + } + + # Copy the image. + call printf ("Saving frame: %d - ") + call pargi (mk_stati (mk, FRAME)) + call flush (STDOUT) + call mk_imcopy (im, sim) + + } then { + call erract (EA_WARN) + call printf ("\n") + } else { + call printf ("done\n") + } + + case MKCMD_RESTORE: + if (sim == NULL) { + call printf ("Use :save to define a scratch image.\n") + } else if (IM_LEN(sim,1) != IM_LEN(im,1) || IM_LEN(sim,2) != + IM_LEN(im,2)) { + call printf ( + "Scatch image and the frame buffer have different sizes.\n") + } else { + iferr { + call printf ("Restoring frame: %d - ") + call pargi (mk_stati (mk, FRAME)) + call flush (STDOUT) + call mk_imcopy (sim, im) + } then { + call erract (EA_WARN) + call printf ("\n") + } else { + call printf ("done\n") + } + } + + + default: + call printf ("Unrecognized or ambiguous colon command.\7\n") + } + + call sfree (sp) +end diff --git a/pkg/images/tv/tvmark/mkfind.x b/pkg/images/tv/tvmark/mkfind.x new file mode 100644 index 00000000..5824422a --- /dev/null +++ b/pkg/images/tv/tvmark/mkfind.x @@ -0,0 +1,52 @@ +include + +# MK_FIND -- Procedure to detect the object in a file closest to the +# input cursor position. + +int procedure mk_find (cl, xcur, ycur, xlist, ylist, label, id, ltid, tol) + +int cl # coordinates file descriptor +real xcur, ycur # x and y cursor position +real xlist, ylist # x and y list position +char label[ARB] # label string +int id # sequence number of detected object in list +int ltid # current sequence number in the list +real tol # tolerance for detection + +real x, y, dist2, ldist2, tol2 +int fscan(), nscan() + +begin + if (cl == NULL) + return (0) + call seek (cl, BOF) + ltid = 0 + + # Initialize + id = 0 + dist2 = MAX_REAL + tol2 = tol ** 2 + + # Fetch the coordinates. + while (fscan (cl) != EOF) { + call gargr (x) + call gargr (y) + call gargwrd (label, SZ_LINE) + if (nscan () < 2) + next + if (nscan () < 3) + label[1] = EOS + ltid = ltid + 1 + ldist2 = (x - xcur) ** 2 + (y - ycur) ** 2 + if (ldist2 > tol2) + next + if (ldist2 > dist2) + next + xlist = x + ylist = y + dist2 = ldist2 + id = ltid + } + + return (id) +end diff --git a/pkg/images/tv/tvmark/mkgmarks.x b/pkg/images/tv/tvmark/mkgmarks.x new file mode 100644 index 00000000..46e9bf05 --- /dev/null +++ b/pkg/images/tv/tvmark/mkgmarks.x @@ -0,0 +1,214 @@ +include +include + +# MK_GMARKS -- Procedure to extract mark values from a string + +int procedure mk_gmarks (str, marks, max_nmarks) + +char str[ARB] # string +real marks[ARB] # number of marks +int max_nmarks # maximum number of marks + +int fd, nmarks +int open(), mk_rdmarks(), mk_decmarks() +errchk open(), close() + +begin + nmarks = 0 + + iferr { + fd = open (str, READ_ONLY, TEXT_FILE) + nmarks = mk_rdmarks (fd, marks, max_nmarks) + call close (fd) + } then { + nmarks = mk_decmarks (str, marks, max_nmarks) + } + + return (nmarks) +end + + +# MK_RDMARKS -- Procedure to read out the marks listed one per line +# from a file. + +int procedure mk_rdmarks (fd, marks, max_nmarks) + +int fd # aperture list file descriptor +real marks[ARB] # list of marks +int max_nmarks # maximum number of apertures + +int nmarks +pointer sp, line +int getline(), mk_decmarks() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + nmarks = 0 + while (getline (fd, Memc[line]) != EOF && nmarks < max_nmarks) { + nmarks = nmarks + mk_decmarks (Memc[line], marks[1+nmarks], + max_nmarks - nmarks) + } + + call sfree (sp) + + return (nmarks) +end + + +# MK_DECAPERTS -- Procedure to decode the mark string. + +int procedure mk_decmarks (str, marks, max_nmarks) + +char str[ARB] # aperture string +real marks[ARB] # aperture array +int max_nmarks # maximum number of apertures + +char outstr[SZ_LINE] +int nmarks, ip, op, ndecode, nmk +real mkstart, mkend, mkstep +bool fp_equalr() +int gctor() + +begin + nmarks = 0 + + for (ip = 1; str[ip] != EOS && nmarks < max_nmarks;) { + + mkstart = 0.0 + mkend = 0.0 + mkstep = 0.0 + ndecode = 0 + + # Skip past white space and commas. + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == ',') + ip = ip + 1 + + # Get the number. + op = 1 + while (IS_DIGIT(str[ip]) || str[ip] == '.') { + outstr[op] = str[ip] + ip = ip + 1 + op = op + 1 + } + outstr[op] = EOS + + # Decode the starting aperture. + op = 1 + if (gctor (outstr, op, mkstart) > 0) { + mkend = mkstart + ndecode = 1 + } else + mkstart = 0.0 + + # Skip past white space and commas. + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == ',') + ip = ip + 1 + + # Get the ending aperture + if (str[ip] == ':') { + ip = ip + 1 + + # Get the ending aperture. + op = 1 + while (IS_DIGIT(str[ip]) || str[ip] == '.') { + outstr[op] = str[ip] + ip = ip + 1 + op = op + 1 + } + outstr[op] = EOS + + # Decode the ending aperture. + op = 1 + if (gctor (outstr, op, mkend) > 0) { + ndecode = 2 + mkstep = mkend - mkstart + } + } + + # Skip past white space and commas. + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == ',') + ip = ip + 1 + + # Get the step size. + if (str[ip] == ':') { + ip = ip + 1 + + # Get the step size. + op = 1 + while (IS_DIGIT(str[ip]) || str[ip] == '.') { + outstr[op] = str[ip] + ip = ip + 1 + op = op + 1 + } + outstr[op] = EOS + + # Decode the step size. + op = 1 + if (gctor (outstr, op, mkstep) > 0) { + if (fp_equalr (mkstep, 0.0)) + mkstep = mkend - mkstart + else + ndecode = (mkend - mkstart) / mkstep + 1 + if (ndecode < 0) { + ndecode = -ndecode + mkstep = - mkstep + } + } + } + + # Negative apertures are not permitted. + if (mkstart <= 0.0 || mkend <= 0.0) + break + + # Fill in the apertures. + if (ndecode == 0) { + ; + } else if (ndecode == 1) { + nmarks = nmarks + 1 + marks[nmarks] = mkstart + } else if (ndecode == 2) { + nmarks = nmarks + 1 + marks[nmarks] = mkstart + if (nmarks >= max_nmarks) + break + nmarks = nmarks + 1 + marks[nmarks] = mkend + } else { + for (nmk = 1; nmk <= ndecode && nmarks < max_nmarks; + nmk = nmk + 1) { + nmarks = nmarks + 1 + marks[nmarks] = mkstart + (nmk - 1) * mkstep + } + } + } + + return (nmarks) +end + + +# GCTOR -- Procedure to convert a character variable to a real number. +# This routine is just an interface routine to the IRAF procedure gctod. + +int procedure gctor (str, ip, rval) + +char str[ARB] # string to be converted +int ip # pointer to the string +real rval # real value + +double dval +int nchars +int gctod() + +begin + nchars = gctod (str, ip, dval) + rval = dval + return (nchars) +end diff --git a/pkg/images/tv/tvmark/mkgpars.x b/pkg/images/tv/tvmark/mkgpars.x new file mode 100644 index 00000000..095ed3f7 --- /dev/null +++ b/pkg/images/tv/tvmark/mkgpars.x @@ -0,0 +1,65 @@ +include +include "tvmark.h" + +# MK_GPARS -- Fetch the parameters required for the imark task from the cl. + +procedure mk_gpars (mk) + +pointer mk # pointer to the immark structure + +int mark, dotsize, ip +pointer sp, str +real ratio +bool clgetb() +int clgwrd(), clgeti(), nscan(), btoi(), mk_stati() +real clgetr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Initialize the immark structure. + call mk_init (mk) + + # Get the mark parameters. + mark = clgwrd ("mark", Memc[str], SZ_FNAME, MKTYPELIST) + if (mark > 0) { + call mk_sets (mk, MARK, Memc[str]) + call mk_seti (mk, MKTYPE, mark) + } else { + call mk_sets (mk, MARK, "point") + call mk_seti (mk, MKTYPE, MK_POINT) + } + + # Get the circles descriptor. + call clgstr ("radii", Memc[str], SZ_FNAME) + call mk_sets (mk, CSTRING, Memc[str]) + + # Get the rectangles descriptor. + ip = 1 + call clgstr ("lengths", Memc[str], SZ_LINE) + call sscan (Memc[str]) + call gargwrd (Memc[str], SZ_LINE) + call mk_sets (mk, RSTRING, Memc[str]) + call gargr (ratio) + if (nscan () < 2 || mk_stati (mk, NRECTANGLES) < 1) + call mk_setr (mk, RATIO, 1.0) + else + call mk_setr (mk, RATIO, ratio) + + # Get the rest of the parameters. + call mk_seti (mk, NUMBER, btoi (clgetb ("number"))) + call mk_seti (mk, LABEL, btoi (clgetb ("label"))) + call mk_seti (mk, SIZE, clgeti ("txsize")) + dotsize = clgeti ("pointsize") + if (mod (dotsize, 2) == 0) + dotsize = dotsize + 1 + call mk_seti (mk, SZPOINT, dotsize / 2) + call mk_seti (mk, GRAYLEVEL, clgeti ("color")) + call mk_seti (mk, NXOFFSET, clgeti ("nxoffset")) + call mk_seti (mk, NYOFFSET, clgeti ("nyoffset")) + call mk_setr (mk, TOLERANCE, clgetr ("tolerance")) + + call sfree (sp) +end diff --git a/pkg/images/tv/tvmark/mkgscur.x b/pkg/images/tv/tvmark/mkgscur.x new file mode 100644 index 00000000..529ccc9c --- /dev/null +++ b/pkg/images/tv/tvmark/mkgscur.x @@ -0,0 +1,87 @@ +include +include + +# MK_GSCUR -- Procedure to fetch x and y positions from a file and move +# the cursor to those positions. + +int procedure mk_gscur (sl, gd, xcur, ycur, label, prev_num, req_num, num) + +pointer sl # pointer to text file containing cursor coords +pointer gd # pointer to graphics stream +real xcur, ycur # x cur and y cur +char label[ARB] # label string +int prev_num # previous number +int req_num # requested number +int num # list number + +int stdin, nskip, ncount +pointer sp, fname +int fscan(), nscan(), strncmp() +errchk greactivate, gdeactivate, gscur + +begin + if (sl == NULL) + return (EOF) + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Find the number of objects to be skipped. + call fstats (sl, F_FILENAME, Memc[fname], SZ_FNAME) + if (strncmp ("STDIN", Memc[fname], 5) == 0) { + stdin = YES + nskip = 1 + } else { + stdin = NO + if (req_num <= prev_num) { + call seek (sl, BOF) + nskip = req_num + } else + nskip = req_num - prev_num + } + + ncount = 0 + num = prev_num + repeat { + + # Print the prompt if file is STDIN. + if (stdin == YES) { + call printf ("Type object x and y coordinates: ") + call flush (STDOUT) + } + + # Fetch the coordinates. + if (fscan (sl) != EOF) { + call gargr (xcur) + call gargr (ycur) + call gargwrd (label, SZ_LINE) + if (nscan () >= 2) { + ncount = ncount + 1 + num = num + 1 + } + } else + ncount = EOF + + # Move the cursor. + if (gd != NULL && (ncount == nskip || ncount == EOF)) { + iferr { + call greactivate (gd, 0) + call gscur (gd, xcur, ycur) + call gdeactivate (gd, 0) + } then + ; + } + + } until (ncount == EOF || ncount == nskip) + + call sfree (sp) + + if (ncount == EOF) { + return (EOF) + } else if (nskip == req_num) { + num = ncount + return (ncount) + } else { + return (num) + } +end diff --git a/pkg/images/tv/tvmark/mkmag.x b/pkg/images/tv/tvmark/mkmag.x new file mode 100644 index 00000000..956f50b4 --- /dev/null +++ b/pkg/images/tv/tvmark/mkmag.x @@ -0,0 +1,20 @@ +include + +# MK_MAG -- Procedure to compute the x and y magnification factors. + +procedure mk_mag (im, iw, xmag, ymag) + +pointer im # pointer to the frame buffer +pointer iw # pointer to the wcs structure +real xmag, ymag # x and y magnifications + +real xll, yll, xur, yur + +begin + # Compute the x and y magnification. + call iw_fb2im (iw, 1.0, 1.0, xll, yll) + call iw_fb2im (iw, real (IM_LEN(im,1)), real (IM_LEN(im,2)), xur, yur) + + xmag = abs (xur - xll) / (IM_LEN(im,1) - 1) + ymag = abs (yur - yll) / (IM_LEN(im,2) - 1) +end diff --git a/pkg/images/tv/tvmark/mkmark.x b/pkg/images/tv/tvmark/mkmark.x new file mode 100644 index 00000000..72583fcb --- /dev/null +++ b/pkg/images/tv/tvmark/mkmark.x @@ -0,0 +1,482 @@ +include +include +include "tvmark.h" + +define HELPFILE "iraf$lib/scr/tvmark.key" + +# MK_MARK -- Procedure to mark symbols in the frame buffer interactively. + +int procedure mk_mark (mk, im, iw, cl, dl, log, fnt, autolog, interactive) + +pointer mk # pointer to the mark structure +pointer im # frame image descriptor +pointer iw # pointer to the wcs structure +int cl # coordinate file descriptor +int dl # pointer to the deletions file +int log # output log file descriptor +int fnt # font file descriptor +int autolog # automatic logging enabled +int interactive # interactive mode + +int ncmd, ncols, nlines, nc, nr +int wcs, bkey, skey, vkey, ekey, fkey, okey, key +int id, ltid, ndelete, req_num, lreq_num, prev_num, newlist +pointer sim, sp, scratchim, cmd, str, keepcmd, label +real cwx, cwy, wx, wy, owx, owy, fx, fy, ofx, ofy +real xlist, ylist, oxlist, oylist, rmax + +int imd_gcur(), mk_stati(), strdic(), mk_gscur(), nscan(), mk_new() +int mk_find(), fstati() +real mk_statr() + +begin + # Allocate working memory. + call smark (sp) + call salloc (scratchim, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (keepcmd, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (label, SZ_LINE, TY_CHAR) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + sim = NULL + + # Reinitialize. + ekey = ' ' + fkey = ' ' + okey = ' ' + skey = ' ' + vkey = ' ' + bkey = ' ' + ltid = 0 + ndelete = 0 + newlist = NO + owx = INDEFR + owy = INDEFR + Memc[cmd] = EOS + Memc[keepcmd] = EOS + + while (imd_gcur ("commands", wx,wy,wcs,key,Memc[cmd],SZ_LINE) != EOF) { + + # Save current cursor coordinates. + cwx = wx + cwy = wy + + # Check for new object. + if (mk_new (wx, wy, owx, owy, xlist, ylist, newlist) == YES) + ; + + # Transform to frame buffer coordinates. + call iw_im2fb (iw, wx, wy, fx, fy) + + switch (key) { + + # Print the help page. + case '?': + if (interactive == YES) + call pagefile (HELPFILE, "Type ? for help, q to quit") + + # Quit the task. + case 'q': + break + + # Keep the previous cursor command. + case 'k': + if (log != NULL) + if (autolog == YES) + call printf ("Automatic logging is already enabled.\n") + else + call mk_logcmd (log, Memc[keepcmd]) + else { + if (interactive == YES) + call printf ("The log file is undefined.\n") + } + + # Rewind the coordinate list. + case 'o': + if (cl != NULL) { + call seek (cl, BOF) + oxlist = INDEFR + oylist = INDEFR + ltid = 0 + } else if (interactive == YES) + call printf ("Coordinate list is undefined.\n") + + # Move to the previous object. + case '-': + if (cl != NULL) { + prev_num = ltid + req_num = ltid - 1 + if (req_num < 1) { + if (interactive == YES) + call printf ("Requested object is less than 1.\n") + } else if (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + if (interactive == YES) + call printf ("Moved to object: %d %g %g\n") + call pargi (ltid) + call pargr (xlist) + call pargr (ylist) + newlist = YES + } else if (interactive == YES) + call printf ( + "End of coordinate list, type o to rewind.\n") + } else if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + + # Mark the previous object. + case 'p': + if (cl != NULL) { + prev_num = ltid + req_num = ltid - 1 + if (req_num < 1) { + if (interactive == YES) + call printf ("Requested object is less than 1.\n") + } else if (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + call mk_onemark (mk, im, iw, xlist, ylist, oxlist, + oylist, Memc[label], ltid) + newlist = YES + } else if (interactive == YES) { + call printf ( + "End of coordinate list, type o to rewind.\n") + } + } else if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + + # Move to the next object. + case 'm': + if (cl != NULL) { + prev_num = ltid + req_num = ltid + 1 + if (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + if (interactive == YES) + call printf ("Moved to object: %d %g %g\n") + call pargi (ltid) + call pargr (xlist) + call pargr (ylist) + newlist = YES + } else if (interactive == YES) + call printf ( + "End of coordinate list, type o to rewind.\n") + } else if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + + # Mark the next object. + case 'n': + if (cl != NULL) { + prev_num = ltid + req_num = ltid + 1 + if (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + call mk_onemark (mk, im, iw, xlist, ylist, oxlist, + oylist, Memc[label], ltid) + newlist = YES + } else if (interactive == YES) + call printf ( + "End of coordinate list, type o to rewind.\n") + } else if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + + # Mark the entire list. + case 'l': + if (cl != NULL) { + call seek (cl, BOF) + ltid = 0 + call mk_bmark (mk, im, iw, cl, ltid, fnt) + } else if (interactive == YES) + call printf ("Coordinate list is undefined.\n") + + # Append to the coordinate list. + case 'a': + if (cl == NULL) { + if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + } else if (fstati (cl, F_MODE) != READ_WRITE) { + if (interactive == YES) + call printf ( + "No write permission on coordinate file.\n") + } else { + + # Move to the end of the list. + prev_num = ltid + req_num = ltid + 1 + while (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + prev_num = ltid + req_num = ltid + 1 + } + + # Add the object. + call fprintf (cl, "%g %g\n") + call pargr (wx) + call pargr (wy) + call flush (cl) + ltid = ltid + 1 + #call seek (cl, EOF) + + # Mark the object. + call mk_onemark (mk, im, iw, wx, wy, oxlist, oylist, "", + ltid) + + } + + # Delete an object. + case 'd': + if (cl == NULL) { + if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + } else if (fstati (cl, F_MODE) != READ_WRITE) { + if (interactive == YES) + call printf ( + "No write permission on coordinate file.\n") + } else { + + # Find the nearest object to the cursor and delete. + if (mk_find (cl, wx, wy, xlist, ylist, Memc[label], id, + ltid, mk_statr (mk, TOLERANCE)) > 0) { + call fprintf (dl, "%d\n") + call pargi (id) + ndelete = ndelete + 1 + call mk_onemark (mk, im, iw, xlist, ylist, oxlist, + oylist, Memc[label], ltid) + } else if (interactive == YES) + call printf ("Object not in coordinate list.\n") + + } + + # Draw a dot. + case '.': + call mk_dmark (mk, im, fx, fy) + + # Draw a plus sign. + case '+': + call mk_tmark (mk, im, "+", fx, fy, YES) + + # Draw a cross. + case 'x': + call mk_tmark (mk, im, "x", fx, fy, YES) + + # Mark and erase a region. + case 'e': + if (sim != NULL) { + if ((key == ekey) && (okey == 'e' || okey == 'k')) { + call mk_imsection (mk, sim, im, nint (ofx), nint (fx), + nint (ofy), nint (fy)) + ekey = ' ' + } else { + if (interactive == YES) + call printf ("Type e again to define region.\n") + ekey = key + ofx = fx + ofy = fy + } + } else if (interactive == YES) + call printf ("Define a scratch image with :save.\n") + + # Fill region + case 'f': + if ((key == fkey) && (okey == 'f' || okey == 'k')) { + call mk_imsection (mk, NULL, im, nint (ofx), nint (fx), + nint (ofy), nint (fy)) + fkey = ' ' + } else { + if (interactive == YES) + call printf ("Type f again to define region.\n") + fkey = key + ofx = fx + ofy = fy + } + + # Mark a single circle. + case 'v': + if ((key == vkey) && (okey == 'v' || okey == 'k')) { + rmax = sqrt ((fx - ofx) ** 2 + (fy - ofy) ** 2) + call mk_ocmark (mk, im, iw, ofx, ofy, rmax) + vkey = ' ' + } else { + if (interactive == YES) + call printf ("Type v again to draw circle.\n") + vkey = key + ofx = fx + ofy = fy + } + + # Draw concentric circles. + case 'c': + nc = mk_stati (mk, NCIRCLES) + if (nc > 0) { + call mk_cmark (mk, im, iw, fx, fy) + } else if (interactive == YES) + call printf ("Use :radii to specifiy radii.\n") + + # Draw concentric rectangles. + case 'r': + nr = mk_stati (mk, NRECTANGLES) + if (nr > 0) { + call mk_rmark (mk, im, iw, fx, fy) + } else if (interactive == YES) + call printf ("Use :lengths to specify box lengths.\n") + + # Draw a vector segment. + case 's': + if ((skey == key) && (okey == 's' || okey == 'k')) + call mk_lmark (mk, im, ofx, ofy, fx, fy) + if (interactive == YES) + call printf ("Type s again to draw line segment.\n") + ofx = fx + ofy = fy + skey = key + + # Draw a box + case 'b': + if ((key == bkey) && (okey == 'b' || okey == 'k')) { + call mk_xmark (mk, im, ofx, ofy, fx, fy) + bkey = ' ' + } else { + if (interactive == YES) + call printf ("Type b again to draw box.\n") + bkey = key + ofx = fx + ofy = fy + } + + # Execute the colon command. + case ':': + call sscan (Memc[cmd]) + call gargwrd (Memc[str], SZ_LINE) + ncmd = strdic (Memc[str], Memc[str], SZ_LINE, MKCMDS2) + + if (ncmd <= 0) + call mk_colon (mk, Memc[cmd], im, iw, sim, log, cl, ltid, + dl) + + else if (ncmd == MKCMD2_WTEXT) { + call gargstr (Memc[str], SZ_LINE) + if (Memc[str] != EOS) + call mk_tmark (mk, im, Memc[str], fx, fy, NO) + + } else if (ncmd == MKCMD2_MOVE) { + if (cl != NULL) { + call gargi (req_num) + prev_num = ltid + if (nscan () < 2) + req_num = ltid + 1 + if (req_num < 1) { + if (interactive == YES) + call printf ( + "Requested object is less than 1.\n") + } else if (mk_gscur (cl, NULL, xlist, ylist, + Memc[label], prev_num, req_num, ltid) != EOF) { + if (interactive == YES) + call printf ("Moved to object: %d %g %g\n") + call pargi (ltid) + call pargr (xlist) + call pargr (ylist) + newlist = YES + } else if (interactive == YES) { + call printf ( + "End of coordinate list, type o to rewind.\n") + } + } else if (interactive == YES) + call printf ("Coordinate file is undefined.\n") + + } else if (ncmd == MKCMD2_NEXT) { + if (cl != NULL) { + call gargi (req_num) + call gargi (lreq_num) + prev_num = ltid + if (nscan () < 2) { + req_num = ltid + 1 + lreq_num = req_num + } else if (nscan () < 3) + lreq_num = req_num + while (mk_gscur (cl, NULL, xlist, ylist, Memc[label], + prev_num, req_num, ltid) != EOF) { + if (ltid > lreq_num) + break + call mk_onemark (mk, im, iw, xlist, ylist, oxlist, + oylist, Memc[label], ltid) + newlist = YES + prev_num = ltid + req_num = ltid + 1 + } + } else if (interactive == YES) + call printf ("Coordinate field is undefined.\n") + } + + default: + call printf ("Unrecognized keystroke command.\7\n") + } + + # Encode and log the last cursor command. Do not encode any + # keep commands if autologging is turned off. + + if (autolog == YES) { + call mk_encodecmd (wx, wy, wcs, key, Memc[cmd], Memc[keepcmd]) + if (log == NULL) { + if (interactive == YES) + call printf ("The logfile is undefined.\n") + } else + call mk_logcmd (log, Memc[keepcmd]) + } else if (key != 'k') + call mk_encodecmd (wx, wy, wcs, key, Memc[cmd], Memc[keepcmd]) + + # Get set up for next cursor command. + owx = cwx + owy = cwy + okey = key + Memc[cmd] = EOS + if (newlist == YES) { + oxlist = xlist + oylist = ylist + } + } + + # Delete scratch image. + if (sim != NULL) { + call strcpy (IM_HDRFILE(sim), Memc[scratchim], SZ_FNAME) + call imunmap (sim) + call imdelete (Memc[scratchim]) + } + + call sfree (sp) + + return (ndelete) +end + + +# MK_ENCODECMD -- Encode the cursor command. + +procedure mk_encodecmd (wx, wy, wcs, key, cmd, keepcmd) + +real wx, wy # cursor position +int wcs # world coordinate system +int key # cursor keystroke command +char cmd[ARB] # command +char keepcmd[ARB] # encode cursor command + +begin + call sprintf (keepcmd, SZ_LINE, "%g %g %d %c %s") + call pargr (wx) + call pargr (wy) + call pargi (wcs) + call pargi (key) + call pargstr (cmd) +end + + +# MK_LOGCMD -- Log the command. + +procedure mk_logcmd (log, cmd) + +int log # logfile descriptor +char cmd[ARB] # command + +begin + call fprintf (log, "%s\n") + call pargstr (cmd) +end diff --git a/pkg/images/tv/tvmark/mknew.x b/pkg/images/tv/tvmark/mknew.x new file mode 100644 index 00000000..27a5a3af --- /dev/null +++ b/pkg/images/tv/tvmark/mknew.x @@ -0,0 +1,42 @@ +# MK_NEW -- Procedure to determine whether the current star is the same as +# the previous star and/or whether the current star belongs to the coordinate +# list or not. + +int procedure mk_new (wx, wy, owx, owy, xlist, ylist, newlist) + +real wx # x cursor coordinate +real wy # y cursor coordinate +real owx # old x cursor coordinate +real owy # old y cursor coordinate +real xlist # x list coordinate +real ylist # y list coordinate +int newlist # integer new list + +int newobject +real deltaxy +bool fp_equalr() + +begin + deltaxy = 1.0 + + if (newlist == NO) { + if (! fp_equalr (wx, owx) || ! fp_equalr (wy, owy)) + newobject = YES + else + newobject = NO + } else if ((abs (xlist - wx) <= deltaxy) && + (abs (ylist - wy) <= deltaxy)) { + wx = xlist + wy = ylist + newobject = NO + } else if (fp_equalr (wx, owx) && fp_equalr (wy, owy)) { + wx = xlist + wy = ylist + newobject = NO + } else { + newlist = NO + newobject = YES + } + + return (newobject) +end diff --git a/pkg/images/tv/tvmark/mkonemark.x b/pkg/images/tv/tvmark/mkonemark.x new file mode 100644 index 00000000..91bd9ee0 --- /dev/null +++ b/pkg/images/tv/tvmark/mkonemark.x @@ -0,0 +1,392 @@ +include +include "tvmark.h" + +# MK_ONEMARK -- Procedure to mark symbols in the frame buffer given a +# coordinate list and a mark type. + +procedure mk_onemark (mk, im, iw, wx, wy, owx, owy, label, ltid) + +pointer mk # pointer to the mark structure +pointer im # frame image descriptor +pointer iw # pointer to the wcs structure +real wx, wy # coordinates of current list object +real owx, owy # coordinates of previous list member +char label[ARB] # current label +int ltid # list sequence number + +int ncols, nlines, nr, nc, x1, x2, y1, y2 +pointer sp, str, lengths, radii +real fx, fy, ofx, ofy, xmag, ymag, lmax, lratio, rmax, ratio +int mk_stati(), itoc() +int mk_plimits(), mk_llimits(), mk_rlimits(), mk_climits() +pointer mk_statp() +real mk_statr() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (lengths, MAX_NMARKS, TY_REAL) + call salloc (radii, MAX_NMARKS, TY_REAL) + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + # Convert from image to frame buffer coordinates. + if (IS_INDEFR(owx) || IS_INDEFR(owy)) { + owx = INDEFR + owy = INDEFR + } else + call iw_im2fb (iw, owx, owy, ofx, ofy) + call iw_im2fb (iw, wx, wy, fx, fy) + call mk_mag (im, iw, xmag, ymag) + + switch (mk_stati (mk, MKTYPE)) { + + case MK_POINT: + if (mk_plimits (fx, fy, mk_stati (mk, SZPOINT), + ncols, nlines, x1, x2, y1, y2) == YES) { + call mk_drawpt (im, x1, x2, y1, y2, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + case MK_LINE: + if (! IS_INDEFR(ofx) && ! IS_INDEFR(ofy)) { + if (mk_llimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawline (im, ofx, ofy, fx, fy, x1, x2, y1, y2, + mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + } + + case MK_RECTANGLE: + nr = mk_stati (mk, NRECTANGLES) + if (xmag <= 0.0) { + lmax = 0.0 + call amovkr (0.0, Memr[lengths], nr) + } else { + call adivkr (Memr[mk_statp(mk,RLENGTHS)], xmag, Memr[lengths], + nr) + lmax = Memr[lengths+nr-1] + } + if (ymag <= 0.0) + lratio = 0.0 + else + lratio = mk_statr (mk, RATIO) * xmag / ymag + if (mk_rlimits (fx, fy, lmax, lratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawbox (im, fx, fy, x1, x2, y1, y2, Memr[lengths], + lratio, nr, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + case MK_CIRCLE: + nc = mk_stati (mk, NCIRCLES) + if (xmag <= 0.0) { + rmax = 0.0 + call amovkr (0.0, Memr[radii], nc) + } else { + call adivkr (Memr[mk_statp(mk, RADII)], xmag, Memr[radii], nc) + rmax = Memr[radii+nc-1] + } + if (ymag <= 0.0) + ratio = 0.0 + else + ratio = xmag / ymag + if (mk_climits (fx, fy, rmax, ratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawcircles (im, fx, fy, x1, x2, y1, y2, + Memr[radii], ratio, nc, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + case MK_PLUS: + call mk_textim (im, "+", nint (fx), nint (fy), mk_stati (mk, SIZE), + mk_stati (mk, SIZE), mk_stati (mk, GRAYLEVEL), YES) + call imflush (im) + + case MK_CROSS: + call mk_textim (im, "*", nint (fx), nint (fy), mk_stati (mk, SIZE), + mk_stati (mk, SIZE), mk_stati (mk, GRAYLEVEL), YES) + call imflush (im) + + default: + # Do nothing gracefully + } + + # Number the text file. + if (mk_stati (mk, LABEL) == YES) { + if (label[1] != EOS) { + call mk_textim (im, label, nint (fx) + mk_stati (mk, + NXOFFSET), nint (fy) + mk_stati (mk, NYOFFSET), + mk_stati (mk, SIZE), mk_stati (mk, SIZE), mk_stati (mk, + GRAYLEVEL), NO) + call imflush (im) + } + } else if (mk_stati (mk, NUMBER) == YES) { + if (itoc (ltid, Memc[str], SZ_FNAME) > 0) { + call mk_textim (im, Memc[str], nint (fx) + mk_stati (mk, + NXOFFSET), nint (fy) + mk_stati (mk, NYOFFSET), + mk_stati (mk, SIZE), mk_stati (mk, SIZE), mk_stati (mk, + GRAYLEVEL), NO) + call imflush (im) + } + } + + call sfree (sp) +end + + +# MK_DMARK -- Mark a dot. + +procedure mk_dmark (mk, im, fx, fy) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer +real fx, fy # real coordinates + +int ncols, nlines, x1, y1, x2, y2 +int mk_stati(), mk_plimits() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + if (mk_plimits (fx, fy, mk_stati (mk, SZPOINT), ncols, nlines, + x1, x2, y1, y2) == YES) { + call mk_drawpt (im, x1, x2, y1, y2, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, x2) +end + + +# MK_CMARK -- Mark concentric circle(s). + +procedure mk_cmark (mk, im, iw, fx, fy) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer image +pointer iw # pointer to the wcs structure +real fx, fy # center of circle + +int nc, ncols, nlines, x1, x2, y1, y2 +pointer sp, radii +real xmag, ymag, rmax, ratio +int mk_stati(), mk_climits() +pointer mk_statp() + +begin + nc = mk_stati (mk, NCIRCLES) + if (nc <= 0) + return + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + call mk_mag (im, iw, xmag, ymag) + + call smark (sp) + call salloc (radii, nc, TY_REAL) + + if (xmag <= 0.0) { + rmax = 0.0 + call amovkr (0.0, Memr[radii], nc) + } else { + call adivkr (Memr[mk_statp(mk,RADII)], xmag, Memr[radii], nc) + rmax = Memr[radii+nc-1] + } + if (ymag <= 0.0) + ratio = 0.0 + else + ratio = xmag / ymag + + if (mk_climits (fx, fy, rmax, ratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawcircles (im, fx, fy, x1, x2, y1, y2, Memr[radii], + ratio, nc, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, y2) + + call sfree (sp) +end + + +# MK_OCMARK -- Mark one circle. + +procedure mk_ocmark (mk, im, iw, fx, fy, rmax) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer image +pointer iw # pointer to the wcs structure +real fx, fy # center of circle +real rmax # maximum radius + +int ncols, nlines, x1, x2, y1, y2 +int mk_climits(), mk_stati() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (mk_climits (fx, fy, rmax, 1.0, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawcircles (im, fx, fy, x1, x2, y1, y2, rmax, + 1.0, 1, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, y2) +end + + +# MK_LMARK -- Mark s line segment + +procedure mk_lmark (mk, im, ofx, ofy, fx, fy) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer +real ofx, ofy # coords of first point +real fx, fy # coords of second point + +int ncols, nlines, x1, y1, x2, y2 +int mk_stati(), mk_llimits() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + if (mk_llimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawline (im, ofx, ofy, fx, fy, x1, x2, y1, y2, + mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, y2) +end + + +# MK_TMARK -- Mark a text string + +procedure mk_tmark (mk, im, str, fx, fy, center) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer image +char str[ARB] # character string to be drawn +real fx, fy # lower left coords of string +int center # center the string + +int ncols, nlines +#int x1, x2, y1, y2 +int mk_stati() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + call mk_textim (im, str, nint (fx), nint (fy), mk_stati (mk, SIZE), + mk_stati(mk, SIZE), mk_stati (mk, GRAYLEVEL), center) + call imflush (im) + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x1) + #call mk_seti (mk, Y2, y2) +end + + +# MK_RMARK -- Mark concentric rectangles. + +procedure mk_rmark (mk, im, iw, fx, fy) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer +pointer iw # pointer to the wcs structure +real fx, fy # x and y center coordinates + +int nr, ncols, nlines, x1, y1, x2, y2 +pointer sp, lengths +real xmag, ymag, lmax, lratio +int mk_stati(), mk_rlimits() +pointer mk_statp() +real mk_statr() + +begin + nr = mk_stati (mk, NRECTANGLES) + if (nr <= 0) + return + + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + call mk_mag (im, iw, xmag, ymag) + + call smark (sp) + call salloc (lengths, nr, TY_REAL) + + if (xmag <= 0.0) { + lmax = 0.0 + call amovkr (0.0, Memr[lengths], nr) + } else { + lmax = Memr[mk_statp(mk, RLENGTHS)+nr-1] / xmag + call adivkr (Memr[mk_statp(mk,RLENGTHS)], xmag, Memr[lengths], nr) + } + if (ymag <= 0.0) + lratio = 0.0 + else + lratio = mk_statr (mk, RATIO) * xmag / ymag + + if (mk_rlimits (fx, fy, lmax, lratio, ncols, nlines, x1, x2, + y1, y2) == YES) { + call mk_drawbox (im, fx, fy, x1, x2, y1, y2, Memr[lengths], + lratio, nr, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + } + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, y2) + + call sfree (sp) +end + + +# MK_XMARK -- Procedure to mark a box. + +procedure mk_xmark (mk, im, ofx, ofy, fx, fy) + +pointer mk # pointer to the mark structure +pointer im # pointer to the frame buffer image +real ofx, ofy # first corner coordinates +real fx, fy # second corner coordinates + +int ncols, nlines, x1, x2, y1, y2 +int mk_stati() + +begin + ncols = IM_LEN(im,1) + nlines = IM_LEN(im,2) + + call mk_blimits (ofx, ofy, fx, fy, ncols, nlines, x1, x2, y1, y2) + call mk_pbox (im, x1, x2, y1, y2, mk_stati (mk, GRAYLEVEL)) + call imflush (im) + + #call mk_seti (mk, X1, x1) + #call mk_seti (mk, Y1, y1) + #call mk_seti (mk, X2, x2) + #call mk_seti (mk, Y2, y2) +end diff --git a/pkg/images/tv/tvmark/mkoutname.x b/pkg/images/tv/tvmark/mkoutname.x new file mode 100644 index 00000000..a4ec4f22 --- /dev/null +++ b/pkg/images/tv/tvmark/mkoutname.x @@ -0,0 +1,273 @@ +# MK_OUTNAME -- Procedure to construct an daophot output file name. +# If output is null or a directory a name is constructed from the root +# of the image name and the extension. The disk is searched to avoid +# name collisions. +# +#procedure mk_outname (image, output, ext, name, maxch) +# +#char image[ARB] # image name +#char output[ARB] # output directory or name +#char ext[ARB] # extension +#char name[ARB] # output name +#int maxch # maximum size of name +# +#int ndir +#pointer sp, root +#int fnldir(), strlen(), mk_imroot() +# +#begin +# call smark (sp) +# call salloc (root, SZ_FNAME, TY_CHAR) +# call imgimage (image, Memc[root], maxch) +# +# ndir = fnldir (output, name, maxch) +# if (strlen (output) == ndir) { +# ndir = ndir + mk_imroot (Memc[root], name[ndir+1], maxch) +# call sprintf (name[ndir+1], maxch, ".%s.*") +# call pargstr (ext) +# call mk_version (name, name, maxch) +# } else +# call strcpy (output, name, maxch) +# +# call sfree (sp) +#end + + +# MK_IMROOT -- Procedure to fetch the root image name minus the directory +# specification and the section notation. The length of the root name is +# returned. +# +#int procedure mk_imroot (image, root, maxch) +# +#char image[ARB] # image specification +#char root[ARB] # rootname +#int maxch # maximum number of characters +# +#int nchars +#pointer sp, str +#int fnldir(), strlen() +# +#begin +# call smark (sp) +# call salloc (str, SZ_FNAME, TY_CHAR) +# +# call imgimage (image, root, maxch) +# nchars = fnldir (root, Memc[str], maxch) +# call strcpy (root[nchars+1], root, maxch) +# +# call sfree (sp) +# return (strlen (root)) +#end + + +# MK_VERSION -- Routine to compute the next available version number of a given +# file name template and output the new files name. +# +#procedure mk_version (template, filename, maxch) +# +#char template[ARB] # name template +#char filename[ARB] # output name +#int maxch # maximum number of characters +# +#char period +#int newversion, version, len, ip +#pointer sp, list, name +#int fntgfnb() strldx(), ctoi() +#pointer fntopnb() +# +#begin +# # Allocate temporary space +# call smark (sp) +# call salloc (name, maxch, TY_CHAR) +# period = '.' +# list = fntopnb (template, NO) +# len = strldx (period, template) +# +# # Loop over the names in the list searchng for the highest version. +# newversion = 0 +# while (fntgfnb (list, Memc[name], maxch) != EOF) { +# len = strldx (period, Memc[name]) +# ip = len + 1 +# if (ctoi (Memc[name], ip, version) <= 0) +# next +# newversion = max (newversion, version) +# } +# +# # Make new output file name. +# call strcpy (template, filename, len) +# call sprintf (filename[len+1], maxch, "%d") +# call pargi (newversion + 1) +# +# call fntclsb (list) +# call sfree (sp) +#end + + +# MK_IMNAME -- Procedure to construct an output image name. +# If output is null or a directory a name is constructed from the root +# of the image name and the extension. The disk is searched to avoid +# name collisions. + +procedure mk_imname (image, output, ext, name, maxch) + +char image[ARB] # image name +char output[ARB] # output directory or name +char ext[ARB] # extension +char name[ARB] # output name +int maxch # maximum size of name + +int ndir, nimdir, clindex, clsize +pointer sp, root, str +int fnldir(), strlen() + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + ndir = fnldir (output, name, maxch) + if (strlen (output) == ndir) { + call imparse (image, Memc[root], SZ_FNAME, Memc[str], SZ_FNAME, + Memc[str], SZ_FNAME, clindex, clsize) + nimdir = fnldir (Memc[root], Memc[str], SZ_FNAME) + if (clindex >= 0) { + call sprintf (name[ndir+1], maxch, "%s%d.%s.*") + call pargstr (Memc[root+nimdir]) + call pargi (clindex) + call pargstr (ext) + } else { + call sprintf (name[ndir+1], maxch, "%s.%s.*") + call pargstr (Memc[root+nimdir]) + call pargstr (ext) + } + call mk_oimversion (name, name, maxch) + } else + call strcpy (output, name, maxch) + + call sfree (sp) +end + + +# MK_OIMVERSION -- Routine to compute the next available version number of +# a given file name template and output the new files name. + +procedure mk_oimversion (template, filename, maxch) + +char template[ARB] # name template +char filename[ARB] # output name +int maxch # maximum number of characters + +char period +int newversion, version, len +pointer sp, list, name +int imtopen(), imtgetim(), strldx(), ctoi() + +begin + # Allocate temporary space + call smark (sp) + call salloc (name, maxch, TY_CHAR) + period = '.' + list = imtopen (template) + + # Loop over the names in the list searchng for the highest version. + newversion = 0 + while (imtgetim (list, Memc[name], maxch) != EOF) { + len = strldx (period, Memc[name]) + Memc[name+len-1] = EOS + len = strldx (period, Memc[name]) + len = len + 1 + if (ctoi (Memc[name], len, version) <= 0) + next + newversion = max (newversion, version) + } + + # Make new output file name. + len = strldx (period, template) + call strcpy (template, filename, len) + call sprintf (filename[len+1], maxch, "%d") + call pargi (newversion + 1) + + call imtclose (list) + call sfree (sp) +end + + + +# MK_IMNAME -- Procedure to construct an daophot output image name. +# If output is null or a directory a name is constructed from the root +# of the image name and the extension. The disk is searched to avoid +# name collisions. +# +#procedure mk_imname (image, output, ext, name, maxch) +# +#char image[ARB] # image name +#char output[ARB] # output directory or name +#char ext[ARB] # extension +#char name[ARB] # output name +#int maxch # maximum size of name +# +#int ndir +#pointer sp, root +#int fnldir(), strlen(), mk_imroot() +# +#begin +# call smark (sp) +# call salloc (root, SZ_FNAME, TY_CHAR) +# call imgimage (image, Memc[root], maxch) +# +# ndir = fnldir (output, name, maxch) +# if (strlen (output) == ndir) { +# ndir = ndir + mk_imroot (Memc[root], name[ndir+1], maxch) +# call sprintf (name[ndir+1], maxch, ".%s.*") +# call pargstr (ext) +# call mk_imversion (name, name, maxch) +# } else +# call strcpy (output, name, maxch) +# +# call sfree (sp) +#end + + +# MK_VERSION -- Routine to compute the next available version number of a given +# file name template and output the new files name. +# +#procedure mk_imversion (template, filename, maxch) +# +#char template[ARB] # name template +#char filename[ARB] # output name +#int maxch # maximum number of characters +# +#char period +#int newversion, version, len, ip +#pointer sp, list, name +#int fntgfnb() strldx(), ctoi() +#pointer fntopnb() +# +#begin +# # Allocate temporary space +# call smark (sp) +# call salloc (name, maxch, TY_CHAR) +# period = '.' +# list = fntopnb (template, NO) +# len = strldx (period, template) +# +# # Loop over the names in the list searchng for the highest version. +# newversion = 0 +# while (fntgfnb (list, Memc[name], maxch) != EOF) { +# len = strldx (period, Memc[name]) +# Memc[name+len-1] = EOS +# len = strldx (period, Memc[name]) +# ip = len + 1 +# if (ctoi (Memc[name], ip, version) <= 0) +# next +# newversion = max (newversion, version) +# } +# +# # Make new output file name. +# call strcpy (template, filename, len) +# call sprintf (filename[len+1], maxch, "%d") +# call pargi (newversion + 1) +# +# call fntclsb (list) +# call sfree (sp) +#end diff --git a/pkg/images/tv/tvmark/mkpkg b/pkg/images/tv/tvmark/mkpkg new file mode 100644 index 00000000..0fb0af3b --- /dev/null +++ b/pkg/images/tv/tvmark/mkpkg @@ -0,0 +1,27 @@ +# Make the TVMARK package + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + + +libpkg.a: + mkbmark.x "tvmark.h" + mkcolon.x "tvmark.h" + mkgmarks.x + mkgpars.x "tvmark.h" + mkgscur.x + mkremove.x + mkfind.x + mkppars.x "tvmark.h" + mkmag.x + mkmark.x "tvmark.h" + mknew.x + mkonemark.x "tvmark.h" + mkoutname.x + mkshow.x "tvmark.h" + mktext.x "pixelfont.inc" "asciilook.inc" + mktools.x "tvmark.h" + t_tvmark.x "tvmark.h" + ; diff --git a/pkg/images/tv/tvmark/mkppars.x b/pkg/images/tv/tvmark/mkppars.x new file mode 100644 index 00000000..16fdf8c5 --- /dev/null +++ b/pkg/images/tv/tvmark/mkppars.x @@ -0,0 +1,40 @@ +include +include "tvmark.h" + +# MK_PPARS -- Store the IMMARK parameters. + +procedure mk_ppars (mk) + +pointer mk # pointer to the immark structure + +pointer sp, str +bool itob() +int mk_stati() +real mk_statr() + +begin + # Allocate working space. + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Store the mark type. + call mk_stats (mk, MARK, Memc[str], SZ_LINE) + call clpstr ("mark", Memc[str]) + + # Store the circle and rectangles descriptors. + call mk_stats (mk, CSTRING, Memc[str], SZ_LINE) + call clpstr ("radii", Memc[str]) + call mk_stats (mk, RSTRING, Memc[str], SZ_LINE) + call clpstr ("lengths", Memc[str]) + + call clputb ("number", itob (mk_stati (mk, NUMBER))) + call clputb ("label", itob (mk_stati (mk, LABEL))) + call clputi ("txsize", mk_stati (mk, SIZE)) + call clputi ("pointsize", 2 * mk_stati (mk, SZPOINT) + 1) + call clputi ("color", mk_stati (mk, GRAYLEVEL)) + call clputi ("nxoffset", mk_stati (mk, NXOFFSET)) + call clputi ("nyoffset", mk_stati (mk, NYOFFSET)) + call clputr ("tolerance", mk_statr (mk, TOLERANCE)) + + call sfree (sp) +end diff --git a/pkg/images/tv/tvmark/mkremove.x b/pkg/images/tv/tvmark/mkremove.x new file mode 100644 index 00000000..589fc039 --- /dev/null +++ b/pkg/images/tv/tvmark/mkremove.x @@ -0,0 +1,98 @@ +# MK_REMOVE -- Check the deletions for uniqueness and delete unwanted objects +# from the coordinates file. + +procedure mk_remove (coords, deletions, cl, dl, ndelete) + +char coords[ARB] # coordinate file name +char deletions[ARB] # deletions file name +int cl # coordinate file descriptor +int dl # deletions file descriptor +int ndelete # number of deletions + +int i, ndel, nobj, obj, tcl, tdl, stat +pointer sp, id, tclname, tdlname, line +real xval, yval +int fscan(), nscan(), open(), getline() + +begin + call smark (sp) + call salloc (id, ndelete, TY_INT) + call salloc (tclname, SZ_FNAME, TY_CHAR) + call salloc (tdlname, SZ_FNAME, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + + # Rewind both files to the beginning. + call seek (cl, BOF) + call seek (dl, BOF) + + # Read in the ids of objects to be deleted. + ndel = 0 + while (fscan (dl) != EOF) { + call gargi (Memi[id+ndel]) + ndel = ndel + 1 + } + + # Sort the id numbers. + call asrti (Memi[id], Memi[id], ndelete) + + # Remove id numbers that are not unique. + ndel = 1 + do i = 2, ndelete { + if (Memi[id+i-1] == Memi[id+i-2]) + next + ndel = ndel + 1 + Memi[id+ndel-1] = Memi[id+i-1] + } + + # Open two temporary files. + call mktemp ("tcl", Memc[tclname], SZ_FNAME) + call mktemp ("tdl", Memc[tdlname], SZ_FNAME) + tcl = open (Memc[tclname], NEW_FILE, TEXT_FILE) + tdl = open (Memc[tdlname], NEW_FILE, TEXT_FILE) + + nobj = 0 + do i = 1, ndel { + + obj = Memi[id+i-1] + + repeat { + + stat = getline (cl, Memc[line]) + if (stat == EOF) + break + + call sscan (Memc[line]) + call gargr (xval) + call gargr (yval) + if (nscan () < 2) { + call putline (tcl, Memc[line]) + next + } + + nobj = nobj + 1 + if (nobj < obj) + call putline (tcl, Memc[line]) + else + call putline (tdl, Memc[line]) + + } until (nobj >= obj) + } + + # Copy the remainder of the file. + while (getline (cl, Memc[line]) != EOF) + call putline (tcl, Memc[line]) + + # Cleanup the coords file. + call close (cl) + call close (tcl) + call delete (coords) + call rename (Memc[tclname], coords) + + # Cleanup the delete file. + call close (dl) + call close (tdl) + call delete (deletions) + call rename (Memc[tdlname], deletions) + + call sfree (sp) +end diff --git a/pkg/images/tv/tvmark/mkshow.x b/pkg/images/tv/tvmark/mkshow.x new file mode 100644 index 00000000..cd48992b --- /dev/null +++ b/pkg/images/tv/tvmark/mkshow.x @@ -0,0 +1,95 @@ +include "tvmark.h" + +# MK_SHOW -- Procedure to show the immark parameters + +procedure mk_show (mk) + +pointer mk # pointer to the immark structure + +pointer sp, str +bool itob() +int mk_stati() +real mk_statr() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Print a blank line. + call printf ("\n") + + # Print the frame info. + call printf ("%s: %d %s: %s\n") + call pargstr (KY_FRAME) + call pargi (mk_stati (mk, FRAME)) + call pargstr (KY_COORDS) + call mk_stats (mk, COORDS, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + + # Print the output info. + call printf (" %s: %s %s: %s %s: %b\n") + call pargstr (KY_OUTIMAGE) + call mk_stats (mk, OUTIMAGE, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call mk_stats (mk, LOGFILE, Memc[str], SZ_FNAME) + call pargstr (KY_LOGFILE) + call pargstr (Memc[str]) + call pargstr (KY_AUTOLOG) + call pargb (itob (mk_stati (mk, AUTOLOG))) + + # Print the deletions file info. + call printf (" %s: %s %s: %g\n") + call pargstr (KY_DELETIONS) + call mk_stats (mk, DELETIONS, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call pargstr (KY_TOLERANCE) + call pargr (mk_statr (mk, TOLERANCE)) + + # Print the font info. + call printf (" %s: %s %s: %d\n") + call pargstr (KY_FONT) + call mk_stats (mk, FONT, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call pargstr (KY_GRAYLEVEL) + call pargi (mk_stati (mk, GRAYLEVEL)) + + # Print the mark type info. + call printf (" %s: %s ") + call pargstr (KY_MARK) + call mk_stats (mk, MARK, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + + call printf ("%s: %s ") + call pargstr (KY_CIRCLES) + call mk_stats (mk, CSTRING, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + + call printf ("%s: %s %g\n") + call pargstr (KY_RECTANGLE) + call mk_stats (mk, RSTRING, Memc[str], SZ_FNAME) + call pargstr (Memc[str]) + call pargr (mk_statr (mk, RATIO)) + + call printf (" %s: %d %s: %d\n") + call pargstr (KY_SZPOINT) + call pargi (2 * mk_stati (mk, SZPOINT) + 1) + call pargstr (KY_SIZE) + call pargi (mk_stati (mk, SIZE)) + + call printf (" %s: %b ") + call pargstr (KY_LABEL) + call pargb (itob (mk_stati (mk, LABEL))) + call printf ("%s: %b ") + call pargstr (KY_NUMBER) + call pargb (itob (mk_stati (mk, NUMBER))) + call printf (" %s: %d %s: %d\n") + call pargstr (KY_NXOFFSET) + call pargi (mk_stati (mk, NXOFFSET)) + call pargstr (KY_NYOFFSET) + call pargi (mk_stati (mk, NYOFFSET)) + + # Print a blank line. + call printf ("\n") + + call sfree (sp) +end diff --git a/pkg/images/tv/tvmark/mktext.x b/pkg/images/tv/tvmark/mktext.x new file mode 100644 index 00000000..06a99b37 --- /dev/null +++ b/pkg/images/tv/tvmark/mktext.x @@ -0,0 +1,164 @@ +include +include + +define FONTWIDE 6 +define FONTHIGH 7 +define SZ_LOOKUP 128 +define SZ_FONT 455 +define SZ_PIXARY 5 + +# MK_TEXTIM -- Write a text string into an image using a pixel font for speed. +# Characters are made twice as big as the font by doubling in both axes. + +procedure mk_textim (im, s, x, y, xmag, ymag, value, center) + +pointer im # image to put the text in. +char s[ARB] # text to put in the image. +int x, y # x, y position in the image. +int xmag, ymag # x, y magnification values. +int value # value to use in image for text. +int center # center the string + +int numrow, numcol, numchars, fonthigh, fontwide, xinit, yinit +int i, l, ch, nchar, line, ip, pixary[SZ_PIXARY] +pointer lineget, lineput + +int strlen() +pointer imgl2s(), impl2s() +errchk imgl2s, impl2s + +begin + # Find the length of the string. + numchars = strlen (s) + if (numchars <= 0) + return + + # Calculate height and width of magnified font. + fonthigh = FONTHIGH * ymag + fontwide = FONTWIDE * xmag + + # Check for row/col out of bounds. + numcol= IM_LEN(im,1) + numrow = IM_LEN(im,2) + + # Compute the initial position of the string truncating characters + # is necessary. + if (center == YES) + xinit = x - fontwide * numchars / 2 + else + xinit = x + for (ip = 1; ip <= numchars; ip = ip + 1) { + if (xinit >= 1) + break + xinit = xinit + fontwide + } + + # Return if beginning of string is off image. + if (xinit < 1 || xinit > numcol) + return + + # Truncate the string. + if (xinit > numcol - fontwide * (numchars - ip + 1)) { + numchars = int ((numcol - xinit) / fontwide) + if (numchars <= 0) + return + } + + # Return if the text does not fit in the image. + if (center == YES) + yinit = y - fonthigh * numchars / 2 + else + yinit = y + if ((yinit <= 0) || (yinit > numrow - fonthigh)) + return + + # For each line of the text (backward). + for (i = 1; i <= 7; i = i + 1) { + + line = yinit + (i-1) * ymag + + do l = 1, ymag { + + # Get and put the line of the image. + lineput = impl2s (im, line+(l-1)) + lineget = imgl2s (im, line+(l-1)) + call amovs (Mems[lineget], Mems[lineput], numcol) + + # Put out the font. + do ch = ip, numchars { + nchar = int (s[ch]) + call mk_pixbit (nchar, 8 - i, pixary) + call mk_putpix (pixary, Mems[lineput], numcol, + xinit+(ch-1)*fontwide, value, xmag) + } + + } + } +end + + +# MK_PIXBIT -- Look up which bits should be set for this character on this line. + +procedure mk_pixbit (code, line, bitarray) + +int code # character we are writing +int line # line of the character we are writing +int bitarray[ARB] # bit-array to receive data + +int pix, i +short asciilook[SZ_LOOKUP], font[SZ_FONT] +int bitupk() + +include "pixelfont.inc" +include "asciilook.inc" + +begin + pix = font[asciilook[code+1]+line-1] + bitarray[5] = bitupk (pix, 1, 1) + bitarray[4] = bitupk (pix, 4, 1) + bitarray[3] = bitupk (pix, 7, 1) + bitarray[2] = bitupk (pix, 10, 1) + bitarray[1] = bitupk (pix, 13, 1) +end + + +# MK_PUTPIX -- Put one line of one character into the data array. + +procedure mk_putpix (pixary, array, size, position, value, xmag) + +int pixary[ARB] # array of pixels in character +int size, position # size of data array +short array[size] # data array in which to put character line +int value # value to use for character pixels +int xmag # x-magnification of text + +int i, k, x + +begin + do i = 1, 5 { + if (pixary[i] == 1) { + x = position + (i-1) * xmag + do k = 1, xmag + array[x+(k-1)] = value + } + } +end + + +# MK_TLIMITS -- Compute the column and line limits of a text string. + +procedure mk_tlimits (str, x, y, xmag, ymag, ncols, nlines, x1, x2, y1, y2) + +char str[ARB] # string to be written to the image +int x, y # starting position of the string +int xmag, ymag # magnification factor +int ncols, nlines # dimensions of the image +int x1, x2 # column limits +int y1, y2 # line limits + +begin + x1 = max (1, min (y, ncols)) + x2 = min (ncols, max (1, y + 5 * xmag)) + y1 = max (1, min (y, nlines)) + y2 = min (nlines, max (1, y + 6 * ymag)) +end diff --git a/pkg/images/tv/tvmark/mktools.x b/pkg/images/tv/tvmark/mktools.x new file mode 100644 index 00000000..33f1424b --- /dev/null +++ b/pkg/images/tv/tvmark/mktools.x @@ -0,0 +1,505 @@ +include +include "tvmark.h" + +# MK_INIT -- Procedure to initialize the image marking code. + +procedure mk_init (mk) + +pointer mk # pointer to immark structure + +begin + call malloc (mk, LEN_MARKSTRUCT, TY_STRUCT) + + # Initialize the mark type parameters. + MK_MARK(mk) = EOS + MK_CSTRING(mk) = EOS + MK_RSTRING(mk) = EOS + MK_MKTYPE(mk) = 0 + MK_NCIRCLES(mk) = 0 + MK_NELLIPSES(mk) = 0 + MK_NSQUARES(mk) = 0 + MK_NRECTANGLES(mk) = 0 + MK_NXOFFSET(mk) = 0 + MK_NYOFFSET(mk) = 0 + + # Initialize the mark shape parameters. + MK_RATIO(mk) = 1.0 + MK_ELLIPTICITY(mk) = 0.0 + MK_RTHETA(mk) = 0.0 + MK_ETHETA(mk) = 0.0 + + # Initialize the pointers. + MK_RADII(mk) = NULL + MK_AXES(mk) = NULL + MK_SLENGTHS(mk) = NULL + MK_RLENGTHS(mk) = NULL + + MK_X1(mk) = INDEFI + MK_Y1(mk) = INDEFI + MK_X2(mk) = INDEFI + MK_Y2(mk) = INDEFI + + # Initialize actual drawing parameters. + MK_NUMBER(mk) = NO + MK_LABEL(mk) = NO + MK_FONT(mk) = EOS + MK_GRAYLEVEL(mk) = 0 + MK_SIZE(mk) = 1 + MK_SZPOINT(mk) = 1 + + # Initialize file parameters strings. + MK_IMAGE(mk) = EOS + MK_OUTIMAGE(mk) = EOS + MK_COORDS(mk) = EOS + MK_DELETIONS(mk) = EOS + MK_LOGFILE(mk) = EOS + MK_AUTOLOG(mk) = NO + + # Initilize the display command parameters. + MK_FRAME(mk) = 1 + MK_TOLERANCE(mk) = 1.0 + + # Initialize the buffers. + call mk_rinit (mk) +end + + +# MK_RINIT -- Procedure to initialize the immark structure. + +procedure mk_rinit (mk) + +pointer mk # pointer to immark structure + +begin + call mk_rfree (mk) + call malloc (MK_RADII(mk), MAX_NMARKS, TY_REAL) + call malloc (MK_AXES(mk), MAX_NMARKS, TY_REAL) + call malloc (MK_SLENGTHS(mk), MAX_NMARKS, TY_REAL) + call malloc (MK_RLENGTHS(mk), MAX_NMARKS, TY_REAL) +end + + +# MK_INDEFR -- Procedure to reinitialize the size dependent buffers. + +procedure mk_indefr (mk) + +pointer mk # pointer to immark + +int ncircles, nsquares, nellipses, nrectangles +int mk_stati() + +begin + ncircles = mk_stati (mk, NCIRCLES) + nellipses = mk_stati (mk, NELLIPSES) + nsquares = mk_stati (mk, NSQUARES) + nrectangles = mk_stati (mk, NRECTANGLES) + + if (ncircles > 0) + call amovkr (INDEFR, Memr[MK_RADII(mk)], ncircles) + if (nellipses > 0) + call amovkr (INDEFR, Memr[MK_AXES(mk)], nellipses) + if (nsquares > 0) + call amovkr (INDEFR, Memr[MK_SLENGTHS(mk)], nsquares) + if (nrectangles > 0) + call amovkr (INDEFR, Memr[MK_RLENGTHS(mk)], nrectangles) + +end + + +# MK_REALLOC -- Procedure to reallocate regions buffers. + +procedure mk_realloc (mk, ncircles, nellipses, nsquares, nrectangles) + +pointer mk # pointer to immark structure +int ncircles # number of circles +int nellipses # number of ellipses +int nsquares # number of squares +int nrectangles # number of rectangles + +int nc, ne, ns, nr +int mk_stati() + +begin + if (ncircles > 0) + call realloc (MK_RADII(mk), ncircles, TY_REAL) + else { + call mfree (MK_RADII(mk), TY_REAL) + MK_RADII(mk) = NULL + } + + if (nellipses > 0) + call realloc (MK_AXES(mk), nellipses, TY_REAL) + else { + call mfree (MK_AXES(mk), TY_REAL) + MK_AXES(mk) = NULL + } + + if (nsquares > 0) + call realloc (MK_SLENGTHS(mk), nsquares, TY_REAL) + else { + call mfree (MK_SLENGTHS(mk), TY_REAL) + MK_SLENGTHS(mk) = NULL + } + + if (nrectangles > 0) + call realloc (MK_RLENGTHS(mk), nrectangles, TY_REAL) + else { + call mfree (MK_RLENGTHS(mk), TY_REAL) + MK_RLENGTHS(mk) = NULL + } + + nc = mk_stati (mk, NCIRCLES) + ne = mk_stati (mk, NELLIPSES) + ns = mk_stati (mk, NSQUARES) + nr = mk_stati (mk, NRECTANGLES) + + if (ncircles > nc) + call amovkr (INDEFR, Memr[MK_RADII(mk)+nc], ncircles - nc) + if (nellipses > ne) + call amovkr (INDEFR, Memr[MK_AXES(mk)+ne], nellipses - ne) + if (nsquares > ns) + call amovkr (INDEFR, Memr[MK_SLENGTHS(mk)+ns], nsquares - ns) + if (nrectangles > nr) + call amovkr (INDEFR, Memr[MK_RLENGTHS(mk)+nr], nrectangles - nr) +end + + +# MK_FREE -- Procedure to free the immark structure. + +procedure mk_free (mk) + +pointer mk # pointer to immark structure + +begin + call mk_rfree (mk) + call mfree (mk, TY_STRUCT) +end + + +# MK_RFREE -- Procedure to free the regions portion of the immark structure. + +procedure mk_rfree (mk) + +pointer mk # pointer to immark structure + +begin + if (MK_RADII(mk) != NULL) + call mfree (MK_RADII(mk), TY_REAL) + MK_RADII(mk) = NULL + if (MK_AXES(mk) != NULL) + call mfree (MK_AXES(mk), TY_REAL) + MK_AXES(mk) = NULL + if (MK_SLENGTHS(mk) != NULL) + call mfree (MK_SLENGTHS(mk), TY_REAL) + MK_SLENGTHS(mk) = NULL + if (MK_RLENGTHS(mk) != NULL) + call mfree (MK_RLENGTHS(mk), TY_REAL) + MK_RLENGTHS(mk) = NULL +end + + +# MK_STATI -- Procedure to fetch the value of an immark integer parameter. + +int procedure mk_stati (mk, param) + +pointer mk # pointer to immark structure +int param # parameter to be fetched + +begin + switch (param) { + case AUTOLOG: + return (MK_AUTOLOG(mk)) + case NUMBER: + return (MK_NUMBER(mk)) + case LABEL: + return (MK_LABEL(mk)) + case GRAYLEVEL: + return (MK_GRAYLEVEL(mk)) + case SIZE: + return (MK_SIZE(mk)) + case SZPOINT: + return (MK_SZPOINT(mk)) + case FRAME: + return (MK_FRAME(mk)) + case NCIRCLES: + return (MK_NCIRCLES(mk)) + case NELLIPSES: + return (MK_NELLIPSES(mk)) + case NSQUARES: + return (MK_NSQUARES(mk)) + case NRECTANGLES: + return (MK_NRECTANGLES(mk)) + case MKTYPE: + return (MK_MKTYPE(mk)) + case X1: + return (MK_X1(mk)) + case Y1: + return (MK_Y1(mk)) + case X2: + return (MK_X2(mk)) + case Y2: + return (MK_Y2(mk)) + case NXOFFSET: + return (MK_NXOFFSET(mk)) + case NYOFFSET: + return (MK_NYOFFSET(mk)) + default: + call error (0, "MK_STATI: Unknown integer parameter.") + } +end + + +# MK_STATP -- Procedure to fetch the value of a pointer parameter. + +pointer procedure mk_statp (mk, param) + +pointer mk # pointer to immark structure +int param # parameter to be fetched + +begin + switch (param) { + case RADII: + return (MK_RADII(mk)) + case AXES: + return (MK_AXES(mk)) + case SLENGTHS: + return (MK_SLENGTHS(mk)) + case RLENGTHS: + return (MK_RLENGTHS(mk)) + default: + call error (0, "MK_STATP: Unknown pointer parameter.") + } +end + + +# MK_STATR -- Procedure to fetch the value of a real parameter. + +real procedure mk_statr (mk, param) + +pointer mk # pointer to immark structure +int param # parameter to be fetched + +begin + switch (param) { + case RATIO: + return (MK_RATIO(mk)) + case ELLIPTICITY: + return (MK_ELLIPTICITY(mk)) + case RTHETA: + return (MK_RTHETA(mk)) + case ETHETA: + return (MK_ETHETA(mk)) + case TOLERANCE: + return (MK_TOLERANCE(mk)) + default: + call error (0, "MK_STATR: Unknown real parameter.") + } +end + + +# MK_STATS -- Procedure to fetch the value of a string parameter. + +procedure mk_stats (mk, param, str, maxch) + +pointer mk # pointer to immark structure +int param # parameter to be fetched +char str[ARB] # output string +int maxch # maximum number of characters + +begin + switch (param) { + case IMAGE: + call strcpy (MK_IMAGE(mk), str, maxch) + case OUTIMAGE: + call strcpy (MK_OUTIMAGE(mk), str, maxch) + case COORDS: + call strcpy (MK_COORDS(mk), str, maxch) + case DELETIONS: + call strcpy (MK_DELETIONS(mk), str, maxch) + case LOGFILE: + call strcpy (MK_LOGFILE(mk), str, maxch) + case FONT: + call strcpy (MK_FONT(mk), str, maxch) + case MARK: + call strcpy (MK_MARK(mk), str, maxch) + case CSTRING: + call strcpy (MK_CSTRING(mk), str, maxch) + case RSTRING: + call strcpy (MK_RSTRING(mk), str, maxch) + default: + call error (0, "MK_STATS: Unknown string parameter.") + } +end + + +# MK_SETI -- Procedure to set the value of an integer parameter. + +procedure mk_seti (mk, param, value) + +pointer mk # pointer to immark structure +int param # parameter to be fetched +int value # value of the integer parameter + +begin + switch (param) { + case AUTOLOG: + MK_AUTOLOG(mk) = value + case NUMBER: + MK_NUMBER(mk) = value + case LABEL: + MK_LABEL(mk) = value + case GRAYLEVEL: + MK_GRAYLEVEL(mk) = value + case SIZE: + MK_SIZE(mk) = value + case SZPOINT: + MK_SZPOINT(mk) = value + case FRAME: + MK_FRAME(mk) = value + case NCIRCLES: + MK_NCIRCLES(mk) = value + case NELLIPSES: + MK_NELLIPSES(mk) = value + case NSQUARES: + MK_NSQUARES(mk) = value + case NRECTANGLES: + MK_NRECTANGLES(mk) = value + case MKTYPE: + MK_MKTYPE(mk) = value + case X1: + MK_X1(mk) = value + case Y1: + MK_Y1(mk) = value + case X2: + MK_X2(mk) = value + case Y2: + MK_Y2(mk) = value + case NXOFFSET: + MK_NXOFFSET(mk) = value + case NYOFFSET: + MK_NYOFFSET(mk) = value + default: + call error (0, "MK_SETI: Unknown integer parameter.") + } +end + + +# MK_SETP -- Procedure to set the value of a pointer parameter. + +procedure mk_setp (mk, param, value) + +pointer mk # pointer to immark structure +int param # parameter to be fetched +pointer value # value of the pointer parameter + +begin + switch (param) { + case RADII: + MK_RADII(mk) = value + case AXES: + MK_AXES(mk) = value + case SLENGTHS: + MK_SLENGTHS(mk) = value + case RLENGTHS: + MK_RLENGTHS(mk) = value + default: + call error (0, "MK_SETP: Unknown pointer parameter.") + } +end + + +# MK_SETR -- Procedure to set the value of a real parameter. + +procedure mk_setr (mk, param, value) + +pointer mk # pointer to immark structure +int param # parameter to be fetched +real value # real parameter + +begin + switch (param) { + case RATIO: + MK_RATIO(mk) = value + case ELLIPTICITY: + MK_ELLIPTICITY(mk) = value + case RTHETA: + MK_RTHETA(mk) = value + case ETHETA: + MK_ETHETA(mk) = value + case TOLERANCE: + MK_TOLERANCE(mk) = value + default: + call error (0, "MK_SETR: Unknown real parameter.") + } +end + + +# MK_SETS -- Procedure to set the value of a string parameter. + +procedure mk_sets (mk, param, str) + +pointer mk # pointer to immark structure +int param # parameter to be fetched +char str[ARB] # output string + +int rp, ntemp +pointer sp, rtemp +int fnldir(), mk_gmarks() + +begin + switch (param) { + case IMAGE: + call strcpy (str, MK_IMAGE(mk), SZ_FNAME) + + case OUTIMAGE: + call strcpy (str, MK_OUTIMAGE(mk), SZ_FNAME) + + case COORDS: + rp = fnldir (str, MK_COORDS(mk), SZ_FNAME) + call strcpy (str[rp+1], MK_COORDS(mk), SZ_FNAME) + + case DELETIONS: + rp = fnldir (str, MK_DELETIONS(mk), SZ_FNAME) + call strcpy (str[rp+1], MK_DELETIONS(mk), SZ_FNAME) + + case LOGFILE: + rp = fnldir (str, MK_LOGFILE(mk), SZ_FNAME) + call strcpy (str[rp+1], MK_LOGFILE(mk), SZ_FNAME) + + case FONT: + rp = fnldir (str, MK_FONT(mk), SZ_FNAME) + call strcpy (str[rp+1], MK_FONT(mk), SZ_FNAME) + + case MARK: + call strcpy (str, MK_MARK(mk), SZ_FNAME) + + case CSTRING: + call smark (sp) + call salloc (rtemp, MAX_NMARKS, TY_REAL) + ntemp = mk_gmarks (str, Memr[rtemp], MAX_NMARKS) + if (ntemp > 0) { + call strcpy (str, MK_CSTRING(mk), SZ_FNAME) + MK_NCIRCLES(mk) = ntemp + call realloc (MK_RADII(mk), ntemp, TY_REAL) + call amovr (Memr[rtemp], Memr[MK_RADII(mk)], ntemp) + call asrtr (Memr[MK_RADII(mk)], Memr[MK_RADII(mk)], ntemp) + } + call sfree (sp) + + case RSTRING: + call smark (sp) + call salloc (rtemp, MAX_NMARKS, TY_REAL) + ntemp = mk_gmarks (str, Memr[rtemp], MAX_NMARKS) + if (ntemp > 0) { + call strcpy (str, MK_RSTRING(mk), SZ_FNAME) + MK_NRECTANGLES(mk) = ntemp + call realloc (MK_RLENGTHS(mk), ntemp, TY_REAL) + call amovr (Memr[rtemp], Memr[MK_RLENGTHS(mk)], ntemp) + call asrtr (Memr[MK_RLENGTHS(mk)], Memr[MK_RLENGTHS(mk)], ntemp) + } + call sfree (sp) + + default: + call error (0, "MK_SETS: Unknown string parameter.") + } +end diff --git a/pkg/images/tv/tvmark/pixelfont.inc b/pkg/images/tv/tvmark/pixelfont.inc new file mode 100644 index 00000000..92216e6d --- /dev/null +++ b/pkg/images/tv/tvmark/pixelfont.inc @@ -0,0 +1,519 @@ +data (font[i], i=1,7) / 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 00000B / # (space) + +data (font[i], i=8,14) / 00100B, + 00100B, + 00100B, + 00100B, + 00100B, + 00000B, + 00100B / # ! + +data (font[i], i=15,21) / 01010B, + 01010B, + 01010B, + 00000B, + 00000B, + 00000B, + 00000B / # " + +data (font[i], i=22,28) / 01010B, + 01010B, + 11111B, + 01010B, + 11111B, + 01010B, + 01010B / # # + +data (font[i], i=29,35) / 00100B, + 01111B, + 10100B, + 01110B, + 00101B, + 11110B, + 00100B / # $ + +data (font[i], i=36,42) / 11000B, + 11001B, + 00010B, + 00100B, + 01000B, + 10011B, + 00011B / # % + +data (font[i], i=43,49) / 01000B, + 10100B, + 10100B, + 01000B, + 10101B, + 10010B, + 01101B / # & + +data (font[i], i=50,56) / 00100B, + 00100B, + 00100B, + 00000B, + 00000B, + 00000B, + 00000B / # ' + +data (font[i], i=57,63) / 00100B, + 01000B, + 10000B, + 10000B, + 10000B, + 01000B, + 00100B / # ( + +data (font[i], i=64,70) / 00100B, + 00010B, + 00001B, + 00001B, + 00001B, + 00010B, + 00100B / # ) + +data (font[i], i=71,77) / 00100B, + 10101B, + 01110B, + 00100B, + 01110B, + 10101B, + 00100B / # * + +data (font[i], i=78,84) / 00000B, + 00100B, + 00100B, + 11111B, + 00100B, + 00100B, + 00000B / # + + +data (font[i], i=85,91) / 00000B, + 00000B, + 00000B, + 00000B, + 00100B, + 00100B, + 01000B / # , + +data (font[i], i=92,98) / 00000B, + 00000B, + 00000B, + 11111B, + 00000B, + 00000B, + 00000B / # - + +data (font[i], i=99,105) / 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 00100B / # . + +data (font[i], i=106,112) / 00000B, + 00001B, + 00010B, + 00100B, + 01000B, + 10000B, + 00000B / # / + +data (font[i], i=113,119) / 01110B, + 10001B, + 10011B, + 10101B, + 11001B, + 10001B, + 01110B / # 0 + +data (font[i], i=120,126) / 00100B, + 01100B, + 00100B, + 00100B, + 00100B, + 00100B, + 01110B / # 1 + +data (font[i], i=127,133) / 01110B, + 10001B, + 00001B, + 00110B, + 01000B, + 10000B, + 11111B / # 2 + +data (font[i], i=134,140) / 11111B, + 00001B, + 00010B, + 00110B, + 00001B, + 10001B, + 11111B / # 3 + +data (font[i], i=141,147) / 00010B, + 00110B, + 01010B, + 11111B, + 00010B, + 00010B, + 00010B / # 4 + +data (font[i], i=148,154) / 11111B, + 10000B, + 11110B, + 00001B, + 00001B, + 10001B, + 01110B / # 5 + +data (font[i], i=155,161) / 00111B, + 01000B, + 10000B, + 11110B, + 10001B, + 10001B, + 01110B / # 6 + +data (font[i], i=162,168) / 11111B, + 00001B, + 00010B, + 00100B, + 01000B, + 01000B, + 01000B / # 7 + +data (font[i], i=169,175) / 01110B, + 10001B, + 10001B, + 01110B, + 10001B, + 10001B, + 01110B / # 8 + +data (font[i], i=176,182) / 01110B, + 10001B, + 10001B, + 01111B, + 00001B, + 00010B, + 11100B / # 9 + +data (font[i], i=183,189) / 00000B, + 00000B, + 00100B, + 00000B, + 00100B, + 00000B, + 00000B / # : + +data (font[i], i=190,196) / 00000B, + 00000B, + 00100B, + 00000B, + 00100B, + 00100B, + 01000B / # ; + +data (font[i], i=197,203) / 00010B, + 00100B, + 01000B, + 10000B, + 01000B, + 00100B, + 00010B / # < + +data (font[i], i=204,210) / 00000B, + 00000B, + 11111B, + 00000B, + 11111B, + 00000B, + 00000B / # = + +data (font[i], i=211,217) / 01000B, + 00100B, + 00010B, + 00001B, + 00010B, + 00100B, + 01000B / # > + +data (font[i], i=218,224) / 01110B, + 10001B, + 00010B, + 00100B, + 00100B, + 00000B, + 00100B / # ? + +data (font[i], i=225,231) / 01110B, + 10001B, + 10101B, + 10111B, + 10110B, + 10000B, + 01111B / # @ + +data (font[i], i=232,238) / 00100B, + 01010B, + 10001B, + 10001B, + 11111B, + 10001B, + 10001B / # A + +data (font[i], i=239,245) / 11110B, + 10001B, + 10001B, + 11110B, + 10001B, + 10001B, + 11110B / # B + +data (font[i], i=246,252) / 01110B, + 10001B, + 10000B, + 10000B, + 10000B, + 10001B, + 01110B / # C + +data (font[i], i=253,259) / 11110B, + 10001B, + 10001B, + 10001B, + 10001B, + 10001B, + 11110B / # D + +data (font[i], i=260,266) / 11111B, + 10000B, + 10000B, + 11110B, + 10000B, + 10000B, + 11111B / # E + +data (font[i], i=267,273) / 11111B, + 10000B, + 10000B, + 11110B, + 10000B, + 10000B, + 10000B / # F + +data (font[i], i=274,280) / 01111B, + 10000B, + 10000B, + 10000B, + 10011B, + 10001B, + 01111B / # G + +data (font[i], i=281,287) / 10001B, + 10001B, + 10001B, + 11111B, + 10001B, + 10001B, + 10001B / # H + +data (font[i], i=288,294) / 01110B, + 00100B, + 00100B, + 00100B, + 00100B, + 00100B, + 01110B / # I + +data (font[i], i=295,301) / 00001B, + 00001B, + 00001B, + 00001B, + 00001B, + 10001B, + 01110B / # J + +data (font[i], i=302,308) / 10001B, + 10010B, + 10100B, + 11000B, + 10100B, + 10010B, + 10001B / # K + +data (font[i], i=309,315) / 10000B, + 10000B, + 10000B, + 10000B, + 10000B, + 10000B, + 11111B / # L + +data (font[i], i=316,322) / 10001B, + 11011B, + 10101B, + 10101B, + 10001B, + 10001B, + 10001B / # M + +data (font[i], i=323,329) / 10001B, + 10001B, + 11001B, + 10101B, + 10011B, + 10001B, + 10001B / # N + +data (font[i], i=330,336) / 01110B, + 10001B, + 10001B, + 10001B, + 10001B, + 10001B, + 01110B / # O + +data (font[i], i=337,343) / 11110B, + 10001B, + 10001B, + 11110B, + 10000B, + 10000B, + 10000B / # P + +data (font[i], i=344,350) / 01110B, + 10001B, + 10001B, + 10001B, + 10101B, + 10010B, + 01101B / # Q + +data (font[i], i=351,357) / 11110B, + 10001B, + 10001B, + 11110B, + 10100B, + 10010B, + 10001B / # R + +data (font[i], i=358,364) / 01110B, + 10001B, + 10000B, + 01110B, + 00001B, + 10001B, + 01110B / # S + +data (font[i], i=365,371) / 11111B, + 00100B, + 00100B, + 00100B, + 00100B, + 00100B, + 00100B / # T + +data (font[i], i=372,378) / 10001B, + 10001B, + 10001B, + 10001B, + 10001B, + 10001B, + 01110B / # U + +data (font[i], i=379,385) / 10001B, + 10001B, + 10001B, + 10001B, + 10001B, + 01010B, + 00100B / # V + +data (font[i], i=386,392) / 10001B, + 10001B, + 10001B, + 10101B, + 10101B, + 11011B, + 10001B / # W + +data (font[i], i=393,399) / 10001B, + 10001B, + 01010B, + 00100B, + 01010B, + 10001B, + 10001B / # X + +data (font[i], i=400,406) / 10001B, + 10001B, + 01010B, + 00100B, + 00100B, + 00100B, + 00100B / # Y + +data (font[i], i=407,413) / 11111B, + 00001B, + 00010B, + 00100B, + 01000B, + 10000B, + 11111B / # Z + +data (font[i], i=414,420) / 11111B, + 11000B, + 11000B, + 11000B, + 11000B, + 11000B, + 11111B / # [ + +data (font[i], i=421,427) / 00000B, + 10000B, + 01000B, + 00100B, + 00010B, + 00001B, + 00000B / # \ + +data (font[i], i=428,434) / 11111B, + 00011B, + 00011B, + 00011B, + 00011B, + 00011B, + 11111B / # ] + +data (font[i], i=435,441) / 00000B, + 00000B, + 00100B, + 01010B, + 10001B, + 00000B, + 00000B / # ^ + +data (font[i], i=442,448) / 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 00000B, + 11111B / # _ + +data (font[i], i=449,455) / 11111B, + 10001B, + 11011B, + 10101B, + 11011B, + 10001B, + 11111B / # (unknown) diff --git a/pkg/images/tv/tvmark/t_tvmark.x b/pkg/images/tv/tvmark/t_tvmark.x new file mode 100644 index 00000000..d1485ae1 --- /dev/null +++ b/pkg/images/tv/tvmark/t_tvmark.x @@ -0,0 +1,267 @@ +include +include +include +include +include "tvmark.h" + +define TV_NLINES 128 + +# T_TVMARK -- Mark dots circles and squares on the image in the image display +# with optional numbering. + +procedure t_tvmark () + +pointer image # pointer to name of the image +pointer outimage # pointer to output image +pointer coords # pointer to coordinate file +pointer deletions # the name of the deletions file +pointer logfile # pointer to the log file +pointer font # pointer to the font +int autolog # automatically log commands +int interactive # interactive mode + +pointer sp, mk, im, iw, outim, cfilename, tmpname +int cl, dl, log, ft, frame, ltid, wcs_status, ndelete, bufsize + +bool clgetb() +int access(), btoi(), clgeti(), imstati(), mk_mark() +int imd_wcsver() +pointer immap(), open(), imd_mapframe(), iw_open() + +begin + # Set standard output to flush on newline. + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (coords, SZ_FNAME, TY_CHAR) + call salloc (outimage, SZ_FNAME, TY_CHAR) + call salloc (deletions, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + call salloc (font, SZ_FNAME, TY_CHAR) + call salloc (cfilename, SZ_FNAME, TY_CHAR) + call salloc (tmpname, SZ_FNAME, TY_CHAR) + + # Query server to get the WCS version, this also tells us whether + # we can use the all 16 supported frames. + if (imd_wcsver() == 0) + call clputi ("tvmark.frame.p_max", 4) + else + call clputi ("tvmark.frame.p_max", 16) + + frame = clgeti ("frame") + call clgstr ("coords", Memc[coords], SZ_FNAME) + call clgstr ("outimage", Memc[outimage], SZ_FNAME) + call clgstr ("deletions", Memc[deletions], SZ_FNAME) + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + call clgstr ("font", Memc[font], SZ_FNAME) + call clgstr ("commands.p_filename", Memc[cfilename], SZ_FNAME) + autolog = btoi (clgetb ("autolog")) + interactive = btoi (clgetb ("interactive")) + + # Fetch the marking parameters. + call mk_gpars (mk) + + # Open the frame as an image. + im = imd_mapframe (frame, READ_WRITE, YES) + bufsize = max (imstati (im, IM_BUFSIZE), TV_NLINES * + int (IM_LEN(im,1)) * SZ_SHORT) + call imseti (im, IM_BUFSIZE, bufsize) + iw = iw_open (im, frame, Memc[image], SZ_FNAME, wcs_status) + call mk_sets (mk, IMAGE, Memc[image]) + call mk_seti (mk, FRAME, frame) + + # Open the coordinate file. + if (Memc[coords] != EOS) { + if ((interactive == NO) && (Memc[cfilename] == EOS)) { + cl = open (Memc[coords], READ_ONLY, TEXT_FILE) + dl = NULL + } else { + if (access (Memc[coords], READ_WRITE, TEXT_FILE) == YES) + cl = open (Memc[coords], READ_WRITE, TEXT_FILE) + else if (access (Memc[coords], READ_ONLY, TEXT_FILE) == YES) { + cl = open (Memc[coords], READ_ONLY, TEXT_FILE) + call printf ("Warning: File %s is read only.\n") + call pargstr (Memc[coords]) + } else { + cl = open (Memc[coords], NEW_FILE, TEXT_FILE) + call close (cl) + cl = open (Memc[coords], READ_WRITE, TEXT_FILE) + } + call sprintf (Memc[tmpname], SZ_FNAME, "%s.%s") + call pargstr (Memc[coords]) + if (Memc[deletions] == EOS) + call pargstr ("del") + else + call pargstr (Memc[deletions]) + dl = open (Memc[tmpname], NEW_FILE, TEXT_FILE) + call close (dl) + dl = open (Memc[tmpname], READ_WRITE, TEXT_FILE) + } + } else { + cl = NULL + dl = NULL + } + call mk_sets (mk, COORDS, Memc[coords]) + call mk_sets (mk, DELETIONS, Memc[deletions]) + + # Save the output mage name + call mk_sets (mk, OUTIMAGE, Memc[outimage]) + + # Open the font file. + #if (Memc[font] != EOS) + #ft = open (Memc[font], READ_ONLY, TEXT_FILE) + #else + ft = NULL + call mk_sets (mk, FONT, Memc[font]) + + # Mark the image frame. + if (interactive == NO) { + if (Memc[cfilename] != EOS) + ndelete = mk_mark (mk, im, iw, cl, dl, NULL, ft, autolog, NO) + + else { + + # Open the output image. + if (Memc[outimage] != EOS) + outim = immap (Memc[outimage], NEW_COPY, im) + else + outim = NULL + + # Do the marking. + ltid = 0 + if (cl != NULL) + call mk_bmark (mk, im, iw, cl, ltid, ft) + + # Copy / close image. + if (outim != NULL) { + call mk_imcopy (im, outim) + call imunmap (outim) + } + + ndelete = 0 + } + + } else { + + # Open the log file. + if (Memc[logfile] != EOS) + log = open (Memc[logfile], NEW_FILE, TEXT_FILE) + else + log = NULL + call mk_sets (mk, LOGFILE, Memc[logfile]) + call mk_seti (mk, AUTOLOG, autolog) + + ndelete = mk_mark (mk, im, iw, cl, dl, log, ft, autolog, YES) + + if (log != NULL) + call close (log) + } + + # Close up the file lists and free memory. + call iw_close (iw) + call imunmap (im) + if (ft != NULL) + call close (ft) + if (ndelete > 0) { + call mk_remove (Memc[coords], Memc[tmpname], cl, dl, ndelete) + if (Memc[deletions] == EOS) + call delete (Memc[tmpname]) + } else { + if (dl != NULL) { + call close (dl) + call delete (Memc[tmpname]) + } + if (cl != NULL) + call close (cl) + } + + # Free immark structure. + call mkfree (mk) + + call sfree (sp) +end + + +# MK_IMCOPY -- Make a snap of the frame buffer. + +procedure mk_imcopy (in, out) + +pointer in # pointer to the input image +pointer out # pointe to the output image + +int i, ncols, nlines +pointer sp, vin, vout, inbuf, outbuf +pointer imgnls(), impnls() +errchk imgnls(), impnls() + +begin + call smark (sp) + call salloc (vin, IM_MAXDIM, TY_LONG) + call salloc (vout, IM_MAXDIM, TY_LONG) + + ncols = IM_LEN(in, 1) + nlines = IM_LEN(in, 2) + call amovkl (long(1), Meml[vin], IM_MAXDIM) + call amovkl (long(1), Meml[vout], IM_MAXDIM) + + do i = 1, nlines { + if (impnls (out, outbuf, Meml[vout]) == EOF) + call error (0, "Error writing output image.\n") + if (imgnls (in, inbuf, Meml[vin]) == EOF) + call error (0, "Error reading frame buffer.\n") + call amovs (Mems[inbuf], Mems[outbuf], ncols) + } + + call imflush (out) + call sfree (sp) +end + + +# MK_IMSECTION -- Restore a section of an image to an image of the same +# size. + +procedure mk_imsection (mk, in, out, x1, x2, y1, y2) + +pointer mk # pointer to the mark structure +pointer in # input image +pointer out # output image +int x1, x2 # column limits +int y1, y2 # line limits + +short value +int i, ix1, ix2, iy1, iy2, ncols, nlines, mk_stati() +pointer ibuf, obuf +pointer imps2s(), imgs2s() + +begin + ncols = IM_LEN(out,1) + nlines = IM_LEN(out,2) + + ix1 = min (x1, x2) + ix2 = max (x1, x2) + ix1 = max (1, min (ncols, ix1)) + ix2 = min (ncols, max (1, ix2)) + + iy1 = min (y1, y2) + iy2 = max (y1, y2) + iy1 = max (1, min (ncols, iy1)) + iy2 = min (ncols, max (1, iy2)) + + if (in == NULL) { + value = mk_stati (mk, GRAYLEVEL) + do i = iy1, iy2 { + obuf = imps2s (out, ix1, ix2, i, i) + call amovks (value, Mems[obuf], ix2 - ix1 + 1) + } + } else { + do i = iy1, iy2 { + obuf = imps2s (out, ix1, ix2, i, i) + ibuf = imgs2s (in, ix1, ix2, i, i) + call amovs (Mems[ibuf], Mems[obuf], ix2 - ix1 + 1) + } + } + + call imflush (out) +end diff --git a/pkg/images/tv/tvmark/tvmark.h b/pkg/images/tv/tvmark/tvmark.h new file mode 100644 index 00000000..3ff484e2 --- /dev/null +++ b/pkg/images/tv/tvmark/tvmark.h @@ -0,0 +1,165 @@ +# IMMARK Task Header File + +# define IMMARK structure + +define LEN_MARKSTRUCT (40 + 10 * SZ_FNAME + SZ_LINE + 11) + +define MK_AUTOLOG Memi[$1] # Enable auto logging +define MK_NUMBER Memi[$1+1] # Number coordinate list entries +define MK_LABEL Memi[$1+2] # Label coordinate list entries +define MK_GRAYLEVEL Memi[$1+3] # Gray level of marks +define MK_SIZE Memi[$1+4] # Size of numbers and text +define MK_FRAME Memi[$1+5] # Frame number for display +define MK_NCIRCLES Memi[$1+6] # Number of circles +define MK_NELLIPSES Memi[$1+7] # Number of ellipses +define MK_NSQUARES Memi[$1+8] # Number of squares +define MK_NRECTANGLES Memi[$1+9] # Number of rectangles +define MK_MKTYPE Memi[$1+10] # Type of mark +define MK_SZPOINT Memi[$1+11] # Size of point +define MK_NXOFFSET Memi[$1+12] # X offset of number +define MK_NYOFFSET Memi[$1+13] # X offset of number + +define MK_RADII Memi[$1+14] # Pointer to list of radii +define MK_AXES Memi[$1+15] # Pointer to list of semi-major axes +define MK_SLENGTHS Memi[$1+16] # Pointer to list of square lengths +define MK_RLENGTHS Memi[$1+17] # Pointer to list of rectangle lengths + +define MK_RATIO Memr[P2R($1+18)] # Ratio of width/length rectangles +define MK_ELLIPTICITY Memr[P2R($1+19)] # Ellipticity of ellipses +define MK_RTHETA Memr[P2R($1+20)] # Position angle of rectangle +define MK_ETHETA Memr[P2R($1+21)] # Position angle of ellipse + +define MK_X1 Memi[$1+22] # LL corner x coord +define MK_Y1 Memi[$1+23] # LL corner y coord +define MK_X2 Memi[$1+24] # UR corner x coord +define MK_Y2 Memi[$1+25] # UR corner y coord + +define MK_TOLERANCE Memr[P2R($1+26)] # Tolerance for deleting objects + +define MK_IMAGE Memc[P2C($1+40)] # Image name +define MK_OUTIMAGE Memc[P2C($1+40+SZ_FNAME+1)] # Output image +define MK_COORDS Memc[P2C($1+40+2*SZ_FNAME+2)] # Coordinate file +define MK_DELETIONS Memc[P2C($1+40+3*SZ_FNAME+3)] # Deletions files +define MK_LOGFILE Memc[P2C($1+40+4*SZ_FNAME+4)] # Log file +define MK_FONT Memc[P2C($1+40+5*SZ_FNAME+5)] # Font +define MK_MARK Memc[P2C($1+40+6*SZ_FNAME+6)] # Default mark +define MK_CSTRING Memc[P2C($1+40+7*SZ_FNAME+7)] # Default circles +define MK_RSTRING Memc[P2C($1+40+8*SZ_FNAME+8)] # Default rectangles + +# define IMMARK ID's + +define AUTOLOG 1 +define NUMBER 2 +define GRAYLEVEL 3 +define SIZE 4 +define FRAME 5 +define NCIRCLES 6 +define NELLIPSES 7 +define NSQUARES 8 +define NRECTANGLES 9 +define MKTYPE 10 +define RADII 11 +define AXES 12 +define SLENGTHS 13 +define RLENGTHS 14 +define RATIO 15 +define ELLIPTICITY 16 +define RTHETA 17 +define ETHETA 18 +define IMAGE 19 +define OUTIMAGE 20 +define COORDS 21 +define LOGFILE 22 +define FONT 23 +define MARK 25 +define CSTRING 26 +define RSTRING 27 +define SZPOINT 28 +define X1 29 +define Y1 30 +define X2 31 +define Y2 32 +define NXOFFSET 33 +define NYOFFSET 34 +define LABEL 35 +define TOLERANCE 36 +define DELETIONS 37 + +# define mark types + +define MKTYPELIST "|point|circle|rectangle|line|plus|cross|none|" + +define MK_POINT 1 +define MK_CIRCLE 2 +define MK_RECTANGLE 3 +define MK_LINE 4 +define MK_PLUS 5 +define MK_CROSS 6 +define MK_NONE 7 + +# define the fonts + +define MKFONTLIST "|raster|" + +# define IMMARK commands + +define MKCMD_IMAGE 1 +define MKCMD_OUTIMAGE 2 +define MKCMD_COORDS 3 +define MKCMD_LOGFILE 4 +define MKCMD_AUTOLOG 5 +define MKCMD_FRAME 6 +define MKCMD_FONT 7 +define MKCMD_NUMBER 8 +define MKCMD_GRAYLEVEL 9 +define MKCMD_SIZE 10 +define MKCMD_SZPOINT 11 +define MKCMD_MARK 12 +define MKCMD_CIRCLES 13 +define MKCMD_RECTANGLES 14 +define MKCMD_SHOW 15 +define MKCMD_SNAP 16 +define MKCMD_NXOFFSET 17 +define MKCMD_NYOFFSET 18 +define MKCMD_SAVE 19 +define MKCMD_RESTORE 20 +define MKCMD_LABEL 21 +define MKCMD_TOLERANCE 22 +define MKCMD_DELETIONS 23 + +define MKCMD2_WTEXT 1 +define MKCMD2_MOVE 2 +define MKCMD2_NEXT 3 + + +# define IMMARK keywords + +define KY_IMAGE "image" +define KY_OUTIMAGE "outimage" +define KY_COORDS "coords" +define KY_LOGFILE "logfile" +define KY_AUTOLOG "autolog" +define KY_FRAME "frame" +define KY_FONT "font" +define KY_NUMBER "number" +define KY_GRAYLEVEL "color" +define KY_SIZE "txsize" +define KY_SZPOINT "pointsize" +define KY_MARK "mark" +define KY_CIRCLES "radii" +define KY_RECTANGLE "lengths" +define KY_NXOFFSET "nxoffset" +define KY_NYOFFSET "nyoffset" +define KY_RATIO "ratio" +define KY_LABEL "label" +define KY_TOLERANCE "tolerance" +define KY_DELETIONS "deletions" + + +define MKCMDS "|junk|outimage|coords|logfile|autolog|frame|font|number|color|txsize|pointsize|mark|radii|lengths|show|write|nxoffset|nyoffset|save|restore|label|tolerance|deletions|" + +define MKCMDS2 "|text|move|next|" + +# miscellaneous + +define MAX_NMARKS 100 diff --git a/pkg/images/tv/vimexam.par b/pkg/images/tv/vimexam.par new file mode 100644 index 00000000..1e77fb54 --- /dev/null +++ b/pkg/images/tv/vimexam.par @@ -0,0 +1,24 @@ +banner,b,h,yes,,,"Standard banner" +title,s,h,"",,,"Title" +xlabel,s,h,"Vector Distance",,,"X-axis label" +ylabel,s,h,"Pixel Value",,,"Y-axis label" +naverage,i,h,1,1,,"averaging width of strip" +boundary,s,h,"constant",constant|nearest|reflect|wrap|project,,"type of boundary extension to use" +constant,r,h,0.,,,"the constant for constant-valued boundary extension" + +x1,r,h,INDEF,,,X-axis window limit +x2,r,h,INDEF,,,X-axis window limit +y1,r,h,INDEF,,,Y-axis window limit +y2,r,h,INDEF,,,Y-axis window limit +pointmode,b,h,no,,,plot points instead of lines? +marker,s,h,"plus",,,point marker character? +szmarker,r,h,1.,,,marker size +logx,b,h,no,,,log scale x-axis +logy,b,h,no,,,log scale y-axis +box,b,h,yes,,,draw box around periphery of window +ticklabels,b,h,yes,,,label tick marks +majrx,i,h,5,,,number of major divisions along x grid +minrx,i,h,5,,,number of minor divisions along x grid +majry,i,h,5,,,number of major divisions along y grid +minry,i,h,5,,,number of minor divisions along y grid +round,b,h,no,,,round axes to nice values? diff --git a/pkg/images/tv/wcslab.par b/pkg/images/tv/wcslab.par new file mode 100644 index 00000000..6407cc5a --- /dev/null +++ b/pkg/images/tv/wcslab.par @@ -0,0 +1,15 @@ +# Parameter file for WCSLAB + +image,f,a,,,,"Input image" +frame,i,a,1,,,"Default frame number for image display" +usewcs,b,h,no,,,"Use the world coordinate system definition parameters" +wcspars,pset,h,"",,,"World coordinate system definition parameters" +wlpars,pset,h,"",,,"World coordinate system labeling parameters" +fill,b,h,yes,,,"Fill the viewport ?" +vl,r,h,INDEF,0.0,1.0,"Left edge of viewport (0.0:1.1)" +vr,r,h,INDEF,0.0,1.0,"Right edge of viewport (0.0:1.0)" +vb,r,h,INDEF,0.0,1.0,"Bottom edge of viewport (0.0:1.0)" +vt,r,h,INDEF,0.0,1.0,"Top edge of viewport (0.0:1.0)" +overplot,b,h,no,,,"Overplot to an existing plot?" +append,b,h,no,,,"Append to an existing plot?" +device,s,h,"imd",,,"Graphics device" diff --git a/pkg/images/tv/wcslab/mkpkg b/pkg/images/tv/wcslab/mkpkg new file mode 100644 index 00000000..e88e46cb --- /dev/null +++ b/pkg/images/tv/wcslab/mkpkg @@ -0,0 +1,24 @@ +# WCSLAB + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$checkout libds.a ../ +$update libds.a +$checkin libds.a ../ +$exit + +libpkg.a: + t_wcslab.x + ; + +libds.a: + wlutil.x + wcslab.x "wcslab.h"\ + "wcs_desc.h" + wlwcslab.x "wcslab.h" "wcs_desc.h" + wlsetup.x \ + "wcslab.h" "wcs_desc.h" + wlgrid.x "wcslab.h" "wcs_desc.h" + wllabel.x "wcslab.h" "wcs_desc.h" + ; diff --git a/pkg/images/tv/wcslab/t_wcslab.x b/pkg/images/tv/wcslab/t_wcslab.x new file mode 100644 index 00000000..53d5f352 --- /dev/null +++ b/pkg/images/tv/wcslab/t_wcslab.x @@ -0,0 +1,137 @@ +include +include + +# T_WCSLAB -- Procedure to draw labels and grids in sky projection coordinates. +# +# Description +# T_wcslab produces a labelling and grid based on the MWCS of a +# specified image. This is the task interface to the programmer interface +# wcslab. See wcslab.x for more information. +# +# Bugs +# Can only handle sky projections for Right Ascension/Declination. This +# should be able to deal with any of the projections for this system, but +# has only been tested with the Tangent projection. +# + +procedure t_wcslab() + +pointer image # I: name of the image +int frame # I: display frame containing the image +bool do_fill # I: true if the graph fills the specified viewport +int mode # I: the graphics stream mode +pointer device # I: the name of the graphics device +real vl, vr, vb, vt # I: the edges of the graphics viewport + +pointer sp, title, gp, im, mw +real c1, c2, l1, l2 +bool clgetb() +int clgeti(), strncmp() +pointer gopen(), immap(), mw_openim() +real clgetr() + +begin + # Get memory. + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + + # Since all the MWCS information comes from an image open it. + call clgstr ("image", Memc[image], SZ_FNAME) + + if (Memc[image] != EOS) { + + # Open the image. + im = immap (Memc[image], READ_ONLY, 0) + + # Quit if the image is not 2-dimensional. + if (IM_NDIM(im) != 2) { + call eprintf ("Image: %s is not 2-dimensional\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Set the default input image column and line limits. + c1 = 1.0 + c2 = real (IM_LEN(im,1)) + l1 = 1.0 + l2 = real (IM_LEN(im,2)) + + # Open the WCS. + mw = mw_openim (im) + + # Set up the default image title. + call strcpy (Memc[image], Memc[title], SZ_LINE) + call strcat (": ", Memc[title], SZ_LINE) + call strcat (IM_TITLE(im), Memc[title], SZ_LINE) + + } else { + + # Set the image information to undefined. All this will + # be determined in wcslab. + Memc[title] = EOS + im = NULL + mw = NULL + c1 = 0.0 + c2 = 1.0 + l1 = 0.0 + l2 = 1.0 + } + + # Set the graphics mode depending on whether we are appending to a plot + # or starting a new plot. + do_fill = clgetb ("fill") + if (clgetb ("overplot")) + mode = APPEND + else + mode = NEW_FILE + + # Open graphics. + call clgstr ("device", Memc[device], SZ_FNAME) + + # If we are appending, get the previous viewing parameters. + if (clgetb ("append")) { + + gp = gopen (Memc[device], APPEND, STDGRAPH) + call ggview (gp, vl, vr, vb, vt) + do_fill = true + + # If drawing on the image display device try to match viewports. + } else if (strncmp (Memc[device], "imd", 3) == 0) { + + frame = clgeti ("frame") + vl = clgetr ("vl") + vr = clgetr ("vr") + vb = clgetr ("vb") + vt = clgetr ("vt") + if (im != NULL) + call wl_imd_viewport (frame, im, c1, c2, l1, l2, vl, vr, vb, vt) + gp = gopen (Memc[device], mode, STDGRAPH) + + # Otherwise set up a standard viewport. + } else { + vl = clgetr ("vl") + vr = clgetr ("vr") + vb = clgetr ("vb") + vt = clgetr ("vt") + gp = gopen (Memc[device], mode, STDGRAPH) + } + + # Set the viewport. + call gseti (gp, G_WCS, 1) + call wl_map_viewport (gp, c1, c2, l1, l2, vl, vr, vb, vt, do_fill) + + # All reading from CL parameters is now done. Everything necessary to + # do the plotting is in the WCSLAB descriptor. Do it. + call wcslab (mw, c1, c2, l1, l2, gp, Memc[title]) + + # Release the memory. + call gclose (gp) + if (mw != NULL) + call mw_close (mw) + if (im != NULL) + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/images/tv/wcslab/wcs_desc.h b/pkg/images/tv/wcslab/wcs_desc.h new file mode 100644 index 00000000..4f6b2a30 --- /dev/null +++ b/pkg/images/tv/wcslab/wcs_desc.h @@ -0,0 +1,219 @@ +# WCS_DESC - The definition of the WCSLAB descriptor memory structure. +# +# Description +# This include file defines the memory structures and macros needed to +# access elements of a WCSLAB descriptor. The descriptor provides all +# the necessary elements for the routine wcslab to produce a labeled +# graph. +# +# History +# 9May91 - Created the descriptor. Jonathan D. Eisenhamer, STScI. +# 15May91 - Modified the descriptor to contain only pointers to arrays. +# Two routines, wcs_create and wcs_destroy are required to +# create the arrays that are pointed to in the descriptor. +# Also seperated the include file from the wcslab.h file. jde +# 12Jun91 - Rewrote some of the labelling parameters. jde +# 20Jun91 - Redesigned much of the parameters. jde +#--------------------------------------------------------------------------- + +# Value of opposite axis that polar labels should appear along. +define WL_POLAR_LABEL_POSITION Memd[P2D($1)] + +# The rotation between the Logical and World coordinate systems. +define WL_ROTA Memd[P2D($1+2)] + +# Size of the axis titles. +define WL_AXIS_TITLE_SIZE Memr[P2R($1+4)] + +# The offset required to properly calculate positions in the image display. +define WL_IMAGE_X_OFF Memr[P2R($1+5)] +define WL_IMAGE_Y_OFF Memr[P2R($1+6)] + +# Size of the grid labels. +define WL_LABEL_SIZE Memr[P2R($1+7)] + +# Major tick mark size. +define WL_MAJ_TICK_SIZE Memr[P2R($1+8)] + +# Minor tick mark size. +define WL_MIN_TICK_SIZE Memr[P2R($1+9)] + +# Magnification of the text size for the title. +define WL_TITLE_SIZE Memr[P2R($1+10)] + +# The side in polar/near-polar plots not to put Axis 1 labels. +define WL_BAD_LABEL_SIDE Memi[$1+11] + +# The type of graph that will be produced. The possible value are: +# +# UNKNOWN -> Graph type will be determined +# NORMAL -> Approximate a cartesian grid +# POLAR -> Graph center on a pole +# NEAR_POLAR -> Graph very close to a pole + +define WL_GRAPH_TYPE Memi[$1+12] + +# Number of segments each line should be broken into to plot it. +define WL_LINE_SEGMENTS Memi[$1+13] + +# The grid line type for major grids. The possible values are to standard +# IRAF GIO polyline types. +define WL_MAJ_LINE_TYPE Memi[$1+14] + +# The grid line type for minor grids. The possible values are to standard +# IRAF GIO polyline types. +define WL_MIN_LINE_TYPE Memi[$1+15] + +# The number of label points. +define WL_N_LABELS Memi[$1+16] + +# The graphic WCS that is set to NDC units. +define WL_NDC_WCS Memi[$1+17] + +# The graphic WCS used to plot the grid lines. +define WL_PLOT_WCS Memi[$1+18] + +# The direction of the latitude labelling on polar graphs. Possible values are: +# +# BOTTOM -> Towards the bottom of the graph. +# TOP -> Towards the top of the graph. +# RIGHT -> Towards the right of the graph. +# LEFT -> Towards the left of the graph. + +define WL_POLAR_LABEL_DIRECTION Memi[$1+19] + +# The possible axis types. The possible values are: +# +# RA_DEC_TAN - The tangential display in right ascension and declination. +# LINEAR - General linear systems. + +define WL_SYSTEM_TYPE Memi[$1+20] + +# Define which side of the graph will have the title. +define WL_TITLE_SIDE Memi[$1+21] + +# True if the axis mapping has reversed the order of the axis relative +# to the logical system. +define WL_AXIS_FLIP Memi[$1+22] + +# TRUE if the labels should always be printed in full form. +define WL_ALWAYS_FULL_LABEL Memi[$1+23] + +# TRUE if the grid labels should rotate with the grid lines. +define WL_LABEL_ROTATE Memi[$1+26] + +# True if coordinate labels are to be written. +define WL_LABON Memi[$1+27] + +# True if we are to write labels outside the window borders. Else, write +# them inside. +define WL_LABOUT Memi[$1+28] + +# True if we are to draw the major grid lines. +define WL_MAJ_GRIDON Memi[$1+29] + +# True if we are to draw the minor grid lines. +define WL_MIN_GRIDON Memi[$1+30] + +# True if the graph parameters should be written back out to the +# parameter file. +define WL_REMEMBER Memi[$1+31] + +# TRUE if tick marks should point into the graph. +define WL_TICK_IN Memi[$1+32] + +# Titles to label each axis. +define WL_AXIS_TITLE_PTR Memi[$1+33] +define WL_AXIS_TITLE Memc[WL_AXIS_TITLE_PTR($1)+(($2-1)*SZ_LINE)] + +# The sides the axis titles will appear. +define WL_AXIS_TITLE_SIDE_PTR Memi[$1+34] +define WL_AXIS_TITLE_SIDE Memi[WL_AXIS_TITLE_SIDE_PTR($1)+$2-1] + +# Beginning values to start labeling the axes. +define WL_BEGIN_PTR Memi[$1+35] +define WL_BEGIN Memd[WL_BEGIN_PTR($1)+$2-1] + +# The name of the graphics device. +#define WL_DEVICE_PTR Memi[$1+36] +#define WL_DEVICE Memc[WL_DEVICE_PTR($1)] + +# Value to stop labeling the axes. +define WL_END_PTR Memi[$1+37] +define WL_END Memd[WL_END_PTR($1)+$2-1] + +# The graphics descriptor. +define WL_GP Memi[$1+38] + +# The angle of text at this label point. +define WL_LABEL_ANGLE_PTR Memi[$1+40] +define WL_LABEL_ANGLE Memd[WL_LABEL_ANGLE_PTR($1)+$2-1] + +# Which axis the label represents. +define WL_LABEL_AXIS_PTR Memi[$1+41] +define WL_LABEL_AXIS Memi[WL_LABEL_AXIS_PTR($1)+$2-1] + +# The positions of tick mark/grid labels. +define WL_LABEL_POSITION_PTR Memi[$1+42] +define WL_LABEL_POSITION Memd[WL_LABEL_POSITION_PTR($1)+$2-1+(($3-1)*MAX_LABEL_POINTS)] +# +# NOTE: If the axis are transposed, the positions represented here are +# the corrected, transposed values. + +# The sides the labels for each axis should appear on. +define WL_LABEL_SIDE_PTR Memi[$1+43] +define WL_LABEL_SIDE Memb[WL_LABEL_SIDE_PTR($1)+$2-1+(($3-1)*N_SIDES)] + +# The value of the label. +define WL_LABEL_VALUE_PTR Memi[$1+44] +define WL_LABEL_VALUE Memd[WL_LABEL_VALUE_PTR($1)+$2-1] + +# The center of the transformations in the logical system. +define WL_LOGICAL_CENTER_PTR Memi[$1+45] +define WL_LOGICAL_CENTER Memd[WL_LOGICAL_CENTER_PTR($1)+$2-1] + +# The coordinate transformation from Logical to World. +define WL_LWCT Memi[$1+46] + +# Major grid intervals for the axis. +define WL_MAJ_I_PTR Memi[$1+47] +define WL_MAJOR_INTERVAL Memd[WL_MAJ_I_PTR($1)+$2-1] + +# The minor intervals for the axis. +define WL_MIN_I_PTR Memi[$1+48] +define WL_MINOR_INTERVAL Memi[WL_MIN_I_PTR($1)+$2-1] + +# Remember the extent of the labels around the plot box. +define WL_NV_PTR Memi[$1+49] +define WL_NEW_VIEW Memr[WL_NV_PTR($1)+$2-1] + +# The MWL structure. +define WL_MW Memi[$1+50] + +# The values of the sides of the screen. The indexes are defined as follows: +# +# TOP -> Y-axis value at the top of display. +# BOTTOM -> Y-axis value at bottom of display +# RIGHT -> X-axis value at right of display. +# LEFT -> X-axis value at left of display. +# +define WL_SCREEN_BOUNDARY_PTR Memi[$1+51] +define WL_SCREEN_BOUNDARY Memd[WL_SCREEN_BOUNDARY_PTR($1)+$2-1] + +# The title that will be placed on the plot. +define WL_TITLE_PTR Memi[$1+52] +define WL_TITLE Memc[WL_TITLE_PTR($1)] + +# The coordinate transformation from World to Logical. +define WL_WLCT Memi[$1+53] + +# The center of the transformations in the world system. +define WL_WORLD_CENTER_PTR Memi[$1+54] +define WL_WORLD_CENTER Memd[WL_WORLD_CENTER_PTR($1)+$2-1] + +# The length of this structure. +define WL_LEN 55+1 + +#--------------------------------------------------------------------------- +# End of wcs_desc +#--------------------------------------------------------------------------- diff --git a/pkg/images/tv/wcslab/wcslab.h b/pkg/images/tv/wcslab/wcslab.h new file mode 100644 index 00000000..d458d8da --- /dev/null +++ b/pkg/images/tv/wcslab/wcslab.h @@ -0,0 +1,98 @@ +# Definitions file for WCSLAB + +# Define various important dimensions + +define MAX_DIM 10 # Maximum number of dimensions +define N_DIM 2 # Dimensionality of plotting space +define N_SIDES 4 # Number of sides to a window +define MAX_LABEL_POINTS 100 # The maximum number of possible label points +define N_EDGES 20 # Number of edges being examined from the window + +# Define the types of graphs possible. + +define GRAPHTYPES "|normal|polar|near_polar|" +define NORMAL 1 +define POLAR 2 +define NEAR_POLAR 3 + +# Define the graph sides. The ordering matches the calls to the GIO package. + +define GRAPHSIDES "|left|right|bottom|top|" +define LEFT 1 +define RIGHT 2 +define BOTTOM 3 +define TOP 4 + +# Define which index refers to the X-axis and which refers to the Y-axis. + +define X_DIM 1 +define Y_DIM 2 +define AXIS1 1 +define AXIS2 2 + +# Define which axis is longitude and which axis is latitude. + +define LONGITUDE 1 +define LATITUDE 2 + +# Define the available precisions for labelling + +define HOUR 1 +define DEGREE 1 +define MINUTE 2 +define SECOND 3 +define SUBSEC_LOW 4 +define SUBSEC_HIGH 5 + +# Define the possible MWCS transformation types. + +define RA_DEC_DICTIONARY "|tan|arc|sin|tnx|" +define LINEAR_DICTIONARY "|linear|" + +define NUMBER_OF_SUPPORTED_TYPES 2 +define RA_DEC 1 +define LINEAR 2 + +define AXIS 3B # transform all axes in any MWCS call + +# Some useful graphics definitions and defaults + +define NDC_WCS 0 # the base graphics WCS +define POLE_MARK_SHAPE 4 # the pole mark is a cross +define POLE_MARK_SIZE 3.0 # the half-size of the cross +define DISTANCE_TO_POLE 0.1 # % distance to pole for lines of longitude +define LINE_SIZE 1. # line width for lines and ticks +define MIN_ANGLE 10. # minimum angle for text rotation +define BOTTOM_LEFT .1 # default bottom left corner of viewport +define TOP_RIGHT .9 # default top right corner of viewport + +# Units conversion macros + +define RADTOST (240*RADTODEG($1)) # Radians to seconds of time +define RADTOSA (3600*RADTODEG($1)) # Radians to seconds of arc +define STTORAD (DEGTORAD(($1)/240)) # Seconds of time to radians +define SATORAD (DEGTORAD(($1)/3600)) # Seconds of arc to radians +define RADTOHRS (RADTODEG(($1)/15)) # Radians to hours +define HRSTORAD (DEGTORAD(15*($1))) # Hours to radians +define DEGTOST (240*($1)) # Degrees to seconds of time. +define STTODEG (($1)/240) # Seconds of time to degrees. +define DEGTOSA (3600*($1)) # Degrees to seconds of arc. +define SATODEG (($1)/3600) # Seconds of arc to degrees. +define HRSTODEG (($1)*15) # Hours to degrees. +define DEGTOHRS (($1)/15) # Degrees to hours. +define STPERDAY 86400 # Seconds per day + +# Other useful macros + +define INVERT ($1 < 45 || $1 > 315 || ( $1 > 135 && $1 < 225 )) + +# Define the latitudes of the north and south poles + +define NORTH_POLE_LATITUDE 90.0D0 +define SOUTH_POLE_LATITUDE -90.0D0 + +# Define sections of a circle + +define QUARTER_CIRCLE 90.0D0 +define HALF_CIRCLE 180.0D0 +define FULL_CIRCLE 360.0D0 diff --git a/pkg/images/tv/wcslab/wcslab.x b/pkg/images/tv/wcslab/wcslab.x new file mode 100644 index 00000000..a084ae91 --- /dev/null +++ b/pkg/images/tv/wcslab/wcslab.x @@ -0,0 +1,940 @@ +include +include +include +include +include "wcslab.h" +include "wcs_desc.h" +include + + +# WCSLAB -- Procedure to draw labels and grids in sky projection coordinates. +# +# Description +# Wcslab produces a labelling and grid based on the MWCS of a +# specified image. +# +# The only things necessary to run this routine are: +# 1) Open an image and pass the image descriptor in im. +# 2) Open the graphics device and set the desired viewport (with a +# gsview call). +# 3) Make sure that the wlpars pset is available. +# +# Upon return, the graphics system will be in the state that it had been +# left in and a "virtual viewport" will be returned in the arguments +# left, right, bottom, top. This viewport defines the region where labels +# and/or titles were written. If any graphics is performed within this +# region, chances are that something will be overwritten. If any other +# graphics remain outside this region, then what was produced by this +# subroutine will remain untouched. +# +# Bugs +# Can only handle sky projections for Right Ascension/Declination. This +# should be able to deal with any of the projections for this system, but +# has only been tested with the Tangent projection. + +procedure wcslab (mw, log_x1, log_x2, log_y1, log_y2, gp, title) + +pointer mw # I: the wcs descriptor +real log_x1, log_x2 # I/O: the viewport +real log_y1, log_y2 # I/O: the viewport +pointer gp # I: the graphics descriptor +char title[ARB] # I: the image title + +pointer wd +real junkx1, junkx2, junky1, junky2 +bool clgetb() +pointer wl_create() +errchk clgstr + +begin + # Allocate the descriptor. + wd = wl_create() + + # Set the title name. + call strcpy (title, WL_TITLE(wd), SZ_LINE) + + # Set the WCS descriptor. If the descriptor is NULL or if + # the use_wcs parameter is yes, retrieve the parameter + # specified wcs. + if (mw == NULL) + call wl_wcs_params (mw, log_x1, log_x2, log_y1, log_y2) + else if (clgetb ("usewcs")) { + call mw_close (mw) + call wl_wcs_params (mw, junkx1, junkx2, junky1, junky2) + } + WL_MW(wd) = mw + + # Determine axis types. + call wl_get_system_type (WL_MW(wd), WL_SYSTEM_TYPE(wd), + WL_LOGICAL_CENTER(wd,1), WL_WORLD_CENTER(wd,1), WL_AXIS_FLIP(wd)) + if (IS_INDEFI(WL_SYSTEM_TYPE(wd))) + call error (0, "WCSLAB: Image WCS is unsupported\n") + + # Get the parameters. + call wl_gr_inparams (wd) + + # Copy the graphics descriptor. + WL_GP(wd) = gp + + # Set the plot window in pixels (the logical space of the WCS). + WL_SCREEN_BOUNDARY(wd,LEFT) = log_x1 + WL_SCREEN_BOUNDARY(wd,RIGHT) = log_x2 + WL_SCREEN_BOUNDARY(wd,BOTTOM) = log_y1 + WL_SCREEN_BOUNDARY(wd,TOP) = log_y2 + + # Plot and label the coordinate grid. + call wl_wcslab (wd) + + # Return the possibly modified graphics descriptor and viewport. + gp = WL_GP(wd) + call gsview (gp, WL_NEW_VIEW(wd,LEFT), WL_NEW_VIEW(wd,RIGHT), + WL_NEW_VIEW(wd,BOTTOM), WL_NEW_VIEW(wd,TOP)) + + # Save the current parameters. + if (WL_REMEMBER(wd) == YES) + call wl_gr_remparams (wd) + + # Release the memory. + call wl_destroy (wd) +end + + +# WL_CREATE -- Create a WCSLAB descriptor and initialize it. +# +# Description +# This routine allocates the memory for the WCSLAB descriptor and +# subarrays and initializes values. +# +# Returns +# the pointer to the WCSLAB descriptor. + +pointer procedure wl_create() + +int i,j +pointer wd + +begin + # Allocate the descriptor memory. + call malloc (wd, WL_LEN, TY_STRUCT) + + # Allocate the subarrays. + call malloc (WL_AXIS_TITLE_PTR(wd), SZ_LINE * N_DIM, TY_CHAR) + call malloc (WL_AXIS_TITLE_SIDE_PTR(wd), N_SIDES * N_DIM, TY_INT) + call malloc (WL_BEGIN_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_END_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_LABEL_ANGLE_PTR(wd), MAX_LABEL_POINTS, TY_DOUBLE) + call malloc (WL_LABEL_AXIS_PTR(wd), MAX_LABEL_POINTS, TY_INT) + call malloc (WL_LABEL_POSITION_PTR(wd), N_DIM * MAX_LABEL_POINTS, + TY_DOUBLE) + call malloc (WL_LABEL_SIDE_PTR(wd), N_DIM * N_SIDES, TY_INT) + call malloc (WL_LABEL_VALUE_PTR(wd), MAX_LABEL_POINTS, TY_DOUBLE) + call malloc (WL_LOGICAL_CENTER_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_MAJ_I_PTR(wd), N_DIM, TY_DOUBLE) + call malloc (WL_MIN_I_PTR(wd), N_DIM, TY_INT) + call malloc (WL_NV_PTR(wd), N_SIDES, TY_REAL) + call malloc (WL_SCREEN_BOUNDARY_PTR(wd), N_SIDES, TY_DOUBLE) + call malloc (WL_TITLE_PTR(wd), SZ_LINE, TY_CHAR) + call malloc (WL_WORLD_CENTER_PTR(wd), N_DIM, TY_DOUBLE) + + # Initialize the simple values (should be the same as the parameter + # file). + WL_POLAR_LABEL_POSITION(wd) = INDEF + WL_AXIS_TITLE_SIZE(wd) = 1.5 + WL_LABEL_SIZE(wd) = 1.0 + WL_MAJ_TICK_SIZE(wd) = .03 + WL_MIN_TICK_SIZE(wd) = .01 + WL_TITLE_SIZE(wd) = 2.0 + WL_GRAPH_TYPE(wd) = INDEFI + WL_MAJ_LINE_TYPE(wd) = GL_SOLID + WL_MIN_LINE_TYPE(wd) = GL_DOTTED + WL_TITLE_SIDE(wd) = TOP + WL_ALWAYS_FULL_LABEL(wd) = NO + WL_LABEL_ROTATE(wd) = YES + WL_LABON(wd) = YES + WL_LABOUT(wd) = YES + WL_MAJ_GRIDON(wd) = YES + WL_MIN_GRIDON(wd) = NO + WL_REMEMBER(wd) = NO + WL_TICK_IN(wd) = YES + + # Initialize any strings. + call strcpy ("imtitle", WL_TITLE(wd), SZ_LINE) + + # Initialize the axis dependent values. + do i = 1, N_DIM { + WL_AXIS_TITLE(wd,i) = EOS + WL_AXIS_TITLE_SIDE(wd,i) = INDEFI + WL_BEGIN(wd,i) = INDEFD + WL_END(wd,i) = INDEFD + WL_MAJOR_INTERVAL(wd,i) = INDEFD + WL_MINOR_INTERVAL(wd,i) = 5 + do j = 1, N_SIDES + WL_LABEL_SIDE(wd,j,i) = false + } + + # Return the descriptor. + return (wd) +end + + +# WL_WCS_PARAMS -- Read the WCS descriptor from the parameters. +# +# Description +# This procedure returns the WCS descriptor created from task parameters +# and the logical space that will be graphed. +# +# Bugs +# This only deals with two axes. + +procedure wl_wcs_params (mw, log_x1, log_x2, log_y1, log_y2) + +pointer mw # O: The MWCS descriptor. +real log_x1, log_x2, # O: The extent of the logical space to graph. +real log_y1, log_y2 + +real cd[2,2], r[2], w[2] +pointer sp, input, pp +pointer clopset(), mw_open() +real clgpsetr() + +begin + call smark (sp) + call salloc (input, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wcspars") + + # Create an MWCS descriptor. + mw = mw_open (NULL, 2) + + # Get the types. + call clgpset (pp, "ctype1", Memc[input], SZ_LINE) + call wl_decode_ctype (mw, Memc[input], 1) + call clgpset (pp, "ctype2", Memc[input], SZ_LINE) + call wl_decode_ctype (mw, Memc[input], 2) + + # Get the reference coordinates. + r[1] = clgpsetr (pp, "crpix1") + r[2] = clgpsetr (pp, "crpix2") + w[1] = clgpsetr (pp, "crval1") + w[2] = clgpsetr (pp, "crval2") + + # Get the CD matrix. + cd[1,1] = clgpsetr (pp, "cd1_1") + cd[1,2] = clgpsetr (pp, "cd1_2") + cd[2,1] = clgpsetr (pp, "cd2_1") + cd[2,2] = clgpsetr (pp, "cd2_2") + + # Set the Wterm. + call mw_swtermr (mw, r, w, cd, 2) + + # Get the extent of the logical space. + log_x1 = clgpsetr (pp, "log_x1") + log_x2 = clgpsetr (pp, "log_x2") + log_y1 = clgpsetr (pp, "log_y1") + log_y2 = clgpsetr (pp, "log_y2") + + # Close the pset. + call clcpset (pp) + + call sfree (sp) +end + + +# WL_DECODE_CTYPE -- Decode the ctype string into axis type and system type. +# +# Description +# The CTYPE is what is found in FITS keywords CTYPEn. The value may +# contain two pieces of information, always the system type and possibly +# an individual axis type. For systems such as plain old linear systems +# just a system type is defined. However, for celestial systems, both +# types are defined in the form "axistype-systemtype". There may be +# any number of '-' in between the values. + +procedure wl_decode_ctype (mw, input, axno) + +pointer mw # I: the MWCS descriptor +char input[ARB] # I: the string input +int axno # I: the axis being worked on + +int i, input_len, axes[2] +int strncmp(), strldx(), strlen() +string empty "" + +begin + input_len = strlen (input) + + # Fix some characters. + do i = 1, input_len { + if (input[i] == ' ' || input[i] == '\'') + break + else if (IS_UPPER(input[i])) + input[i] = TO_LOWER(input[i]) + else if (input[i] == '_') + input[i] = '-' + } + + # Determine the type of function on this axis. + if (strncmp (input, "linear", 6) == 0) { + call mw_swtype (mw, axno, 1, "linear", empty) + + } else if (strncmp (input, "ra--", 4) == 0) { + axes[1] = axno + if (axno == 1) + axes[2] = 2 + else + axes[2] = 1 + i = strldx ("-", input) + 1 + call mw_swtype (mw, axes, 2, input[i], + "axis 1: axtype = ra axis 2: axtype=dec") + + # This is dealt with in the ra case. + } else if (strncmp (input, "dec-", 4) == 0) { + ; + + } else { + # Since we have to be able to read any FITS header, we have + # no control over the value of CTYPEi. If the value is + # something we don't know about, assume a LINEAR axis, using + # the given value of CTYPEi as the default axis label. + call mw_swtype (mw, axno, 1, "linear", empty) + call mw_swattrs (mw, axno, "label", input) + } + +end + + +# WL_GET_SYSTEM_TYPE -- Determine type of transformation the MWCS represents. +# +# Note +# For some systems, the axis mapping reverses the order to make +# the rest of the code tractable. The only problem is that when graphing, +# the graph routines need to "fix" this reversal. Also note that this +# occurs only for systems that have distinct axis types, such as RA and +# DEC. +# +# Bugs +# A potential problem: For a WCS that has more axes than necessary +# for the sky projections, those axis are set such that during +# transformations, the first index position is used. For the one +# example I have seen, the "third" axis is time and this interpretation +# works. But, I am sure something will fall apart because of this. + +procedure wl_get_system_type (mw, system_type, logical_center, world_center, + flip) + +pointer mw # I: the MWCS descriptor. +int system_type # O: the transformation type: + # RA_DEC -> tan, sin, or arc projection + # in right ascension and + # declination + # LINEAR -> any regular linear system + # INDEFI -> could not be determined +double logical_center[N_DIM] # O: the center point in the logical system. +double world_center[N_DIM] # O: the center point in the world system. +int flip # O: true if the order of the axes have been + # changed by axis mappins + +double tmp_logical[MAX_DIM], tmp_world[MAX_DIM] +int wcs_dim, axis, index_sys1, index_sys2, found_axis +int axno[MAX_DIM], axval[MAX_DIM], found_axis_list[N_DIM] +pointer sp, axtype, cd, cur_type +int mw_stati(), strncmp(), strdic() +errchk mw_gwattrs + +begin + # Get some memory. + call smark (sp) + call salloc (axtype, SZ_LINE, TY_CHAR) + call salloc (cur_type, SZ_LINE, TY_CHAR) + call salloc (cd, MAX_DIM, TY_DOUBLE) + + # Get the dimensionality of the WCS. + call mw_seti (mw, MW_USEAXMAP, NO) + wcs_dim = mw_stati (mw, MW_NDIM) + + # Initialize the two dimensions. + index_sys1 = INDEFI + index_sys2 = INDEFI + + # Look through the possible supported axis types. When a type has + # exactly N_DIM axes defined, that will be the one used. + + for (system_type = 1; system_type <= NUMBER_OF_SUPPORTED_TYPES; + system_type = system_type + 1) { + + # Determine the string that should be looked for. + switch (system_type) { + case RA_DEC: + call strcpy (RA_DEC_DICTIONARY, Memc[cur_type], SZ_LINE) + case LINEAR: + call strcpy (LINEAR_DICTIONARY, Memc[cur_type], SZ_LINE) + } + + # Initialize the number of found axis. + found_axis = 0 + + # Examine each axis to determine whether the current axis type is + # the one to use. + for (axis = 1; axis <= wcs_dim; axis = axis + 1) { + + # If the current physical axis is not mapped, ignore it. + # This statement is causing a problem in 2.10.3, not sure + # why but am removing it for now. + #if (axno[axis] == 0) + #next + + ifnoerr (call mw_gwattrs( mw, axis, "wtype", Memc[axtype], + SZ_LINE)) { + call strlwr (Memc[axtype]) + + # If this axis type matches the one being looked for, add + # it to the axis list. If there are too many axis of the + # current type found, don't add to the found axis list. + + if (strdic (Memc[axtype], Memc[axtype], SZ_LINE, + Memc[cur_type]) > 0) { + found_axis = found_axis + 1 + if (found_axis <= N_DIM) + found_axis_list[found_axis] = axis + } + } + } + + # Check to see whether we have the right number axes. + if (found_axis == N_DIM) + break + + } + + # If any axes were found, then further check axis types. + # Depending on the axis type, there may be need to distinguish + # between the two possible axis further. + + if (found_axis == N_DIM) + switch (system_type) { + case RA_DEC: + for (axis = 1; axis <= N_DIM; axis = axis + 1) + ifnoerr (call mw_gwattrs (mw, found_axis_list[axis], + "axtype", Memc[axtype], SZ_LINE)) { + call strlwr( Memc[axtype] ) + if (strncmp (Memc[axtype], "ra", 2) == 0) + index_sys1 = found_axis_list[axis] + else if (strncmp (Memc[axtype], "dec", 3) == 0) + index_sys2 = found_axis_list[axis] + } + + # The "default" seems to be the LINEAR case for MWCS. + # Since no other information is provided, this is all we know. + default: + index_sys1 = found_axis_list[1] + index_sys2 = found_axis_list[2] + } + + # If either axis is unknown, something is wrong. If the WCS has two + # axes defined, then make some grand assumptions. If not, then there + # is nothing more to be done. + + if (IS_INDEFI (index_sys1) || IS_INDEFI (index_sys2)) { + if (wcs_dim >= N_DIM) { + index_sys1 = 1 + index_sys2 = 2 + } else + call error (0, "Wcslab: Fewer than two defined axes") + } + + # Zero the axis values and set any "unknown" axis to always use the + # "first" position in that axis direction. This will more than likely + # be a problem, but no general solution comes to mind this second. + + call amovki (0, axno, wcs_dim) + call amovki (0, axval, wcs_dim) + + # Setup so that the desired axes are set as the X and Y axis. + axno[index_sys1] = X_DIM + axno[index_sys2] = Y_DIM + call mw_saxmap (mw, axno, axval, wcs_dim) + + # Recover the center points of the Logical and World systems. + call mw_gwtermd (mw, tmp_logical, tmp_world, Memd[cd], wcs_dim) + + logical_center[X_DIM] = tmp_logical[index_sys1] + logical_center[Y_DIM] = tmp_logical[index_sys2] + world_center[X_DIM] = tmp_world[index_sys1] + world_center[Y_DIM] = tmp_world[index_sys2] + + # Check for reversal of axes + if (index_sys1 > index_sys2) + flip = YES + else + flip = NO + + # Release the memory. + call sfree (sp) +end + + +# WL_GR_INPARAMS -- Read in the graphics parameters for wcslab. +# +# Description +# Read all the parameters in and make some decisions about what +# will be done. + +procedure wl_gr_inparams (wd) + +pointer wd # I: the WCSLAB descriptor + +pointer sp, aline, pp +bool clgpsetb(), streq() +double wl_string_to_internal() +int btoi(), strdic(), wl_line_type(), clgpseti() +pointer clopset() +real clgpsetr() + +begin + # Get some memory. + call smark (sp) + call salloc (aline, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wlpars") + + # Get the title if other than the default. + call clgpset (pp, "title", Memc[aline], SZ_LINE) + if (! streq (Memc[aline], "imtitle")) + call strcpy (Memc[aline], WL_TITLE(wd), SZ_LINE) + + # Get the axis titles. + call clgpset (pp, "axis1_title", WL_AXIS_TITLE(wd,AXIS1), SZ_LINE) + call clgpset (pp, "axis2_title", WL_AXIS_TITLE(wd,AXIS2), SZ_LINE) + + # Get the parameters. + WL_ALWAYS_FULL_LABEL(wd) = btoi (clgpsetb (pp,"full_label")) + WL_AXIS_TITLE_SIZE(wd) = clgpsetr (pp, "axis_title_size") + WL_LABEL_ROTATE(wd) = btoi (clgpsetb (pp, "rotate")) + WL_LABEL_SIZE(wd) = clgpsetr (pp, "label_size") + WL_LABON(wd) = btoi (clgpsetb (pp, "dolabel")) + WL_LABOUT(wd) = btoi (clgpsetb (pp, "labout")) + WL_MAJ_GRIDON(wd) = btoi (clgpsetb (pp, "major_grid")) + WL_MAJ_TICK_SIZE(wd) = clgpsetr (pp, "major_tick") + WL_MIN_GRIDON(wd) = btoi (clgpsetb (pp, "minor_grid")) + WL_MINOR_INTERVAL(wd,AXIS1) = clgpseti (pp, "axis1_minor") + WL_MINOR_INTERVAL(wd,AXIS2) = clgpseti (pp, "axis2_minor") + WL_MIN_TICK_SIZE(wd) = clgpsetr (pp, "minor_tick") + WL_REMEMBER(wd) = btoi (clgpsetb (pp, "remember")) + WL_TICK_IN(wd) = btoi (clgpsetb (pp, "tick_in")) + WL_TITLE_SIZE(wd) = clgpsetr (pp, "title_size") + + # Set what type of graph will be plotted. + call clgpset (pp, "graph_type", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_GRAPH_TYPE(wd) = strdic (Memc[aline], Memc[aline], SZ_LINE, + GRAPHTYPES) + if (WL_GRAPH_TYPE(wd) <= 0) + WL_GRAPH_TYPE(wd) = INDEFI + + # Get which sides labels will appear on. + call clgpset (pp, "axis1_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + call wl_label_side (Memc[aline], WL_LABEL_SIDE(wd,1,AXIS1)) + + call clgpset (pp, "axis2_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + call wl_label_side (Memc[aline], WL_LABEL_SIDE(wd,1,AXIS2)) + + # Get the polar justification direction. + call clgpset (pp, "justify", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_POLAR_LABEL_DIRECTION(wd) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_POLAR_LABEL_DIRECTION(wd) <= 0) + WL_POLAR_LABEL_DIRECTION(wd) = INDEFI + + # Decode the graphing parameters. + call clgpset (pp, "axis1_int", Memc[aline], SZ_LINE) + WL_MAJOR_INTERVAL(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + call clgpset (pp, "axis1_beg", Memc[aline], SZ_LINE) + WL_BEGIN(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + call clgpset (pp, "axis1_end", Memc[aline], SZ_LINE) + WL_END(wd,AXIS1) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + + call clgpset (pp, "axis2_int", Memc[aline], SZ_LINE) + WL_MAJOR_INTERVAL(wd,AXIS2) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2) + call clgpset (pp, "axis2_beg", Memc[aline], SZ_LINE) + WL_BEGIN(wd,AXIS2) = wl_string_to_internal(Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2 ) + call clgpset (pp, "axis2_end", Memc[aline], SZ_LINE) + WL_END(wd,AXIS2) = wl_string_to_internal (Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS2) + + # Get the polar label position. + call clgpset (pp, "axis2_dir", Memc[aline], SZ_LINE) + WL_POLAR_LABEL_POSITION(wd) = wl_string_to_internal( Memc[aline], + WL_SYSTEM_TYPE(wd), AXIS1) + + # Get the axis titles. + call clgpset (pp, "axis1_title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_AXIS_TITLE_SIDE(wd,AXIS1) <= 0) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = INDEFI + + call clgpset (pp, "axis2_title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[aline]) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = strdic (Memc[aline], Memc[aline], + SZ_LINE, GRAPHSIDES) + if (WL_AXIS_TITLE_SIDE(wd,AXIS2) <= 0) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = INDEFI + + # Decode the grid line types. + call clgpset (pp, "major_line", Memc[aline], SZ_LINE) + WL_MAJ_LINE_TYPE(wd) = wl_line_type (Memc[aline]) + call clgpset (pp, "minor_line", Memc[aline], SZ_LINE) + WL_MIN_LINE_TYPE(wd) = wl_line_type (Memc[aline]) + + # Get the title side. + call clgpset (pp, "title_side", Memc[aline], SZ_LINE) + call strlwr (Memc[ aline]) + WL_TITLE_SIDE(wd) = strdic (Memc[aline], Memc[aline], SZ_LINE, + GRAPHSIDES) + + # Close the pset. + call clcpset (pp) + + # Free memory. + call sfree (sp) +end + + +# WL_GR_REMPARAMS -- Write out the graphing parameters. + +procedure wl_gr_remparams (wd) + +pointer wd # I: the WCSLAB descriptor. + +pointer sp, output, pp +pointer clopset() + +begin + # Get some memory. + call smark (sp) + call salloc (output, SZ_LINE, TY_CHAR) + + # Open the pset. + pp = clopset ("wlpars") + + # Set the graph type. + switch (WL_GRAPH_TYPE(wd)) { + case NORMAL: + call clppset (pp, "graph_type", "normal") + case POLAR: + call clppset (pp, "graph_type", "polar") + case NEAR_POLAR: + call clppset (pp, "graph_type", "near_polar") + default: + call clppset (pp, "graph_type", "default") + } + + # Write back the labelling parameters. + call wl_internal_to_string (WL_MAJOR_INTERVAL(wd,AXIS1), + WL_SYSTEM_TYPE(wd), AXIS1, Memc[output]) + call clppset (pp, "axis1_int", Memc[output]) + call wl_internal_to_string (WL_BEGIN(wd,AXIS1), WL_SYSTEM_TYPE(wd), + AXIS1, Memc[output]) + call clppset (pp, "axis1_beg", Memc[output]) + call wl_internal_to_string (WL_END(WD,AXIS1), WL_SYSTEM_TYPE(wd), + AXIS1, Memc[output]) + call clppset (pp, "axis1_end", Memc[output]) + call wl_internal_to_string (WL_MAJOR_INTERVAL(wd,AXIS2), + WL_SYSTEM_TYPE(wd), AXIS2, Memc[output]) + call clppset (pp, "axis2_int", Memc[output]) + call wl_internal_to_string (WL_BEGIN(wd,AXIS2), WL_SYSTEM_TYPE(wd), + AXIS2, Memc[output]) + call clppset (pp, "axis2_beg", Memc[output]) + call wl_internal_to_string (WL_END(wd,AXIS2), WL_SYSTEM_TYPE(wd), + AXIS2, Memc[output]) + call clppset (pp, "axis2_end", Memc[output]) + call wl_internal_to_string (WL_POLAR_LABEL_POSITION(wd), + WL_SYSTEM_TYPE(wd), AXIS1, Memc[output]) + call clppset (pp, "axis2_dir", Memc[output]) + + # Write back labelling justification. + call wl_side_to_string (WL_POLAR_LABEL_DIRECTION(wd), Memc[output], + SZ_LINE) + call clppset (pp, "justify", Memc[output]) + + # Put the axis title sides out. + call wl_side_to_string (WL_AXIS_TITLE_SIDE(wd,AXIS1), Memc[output], + SZ_LINE) + call clppset (pp, "axis1_title_side", Memc[output]) + call wl_side_to_string (WL_AXIS_TITLE_SIDE(wd,AXIS2), Memc[output], + SZ_LINE ) + call clppset (pp, "axis2_title_side", Memc[output]) + + # Put the label sides out. + call wl_put_label_sides (WL_LABEL_SIDE(wd,1,AXIS1), Memc[output], + SZ_LINE ) + call clppset (pp, "axis1_side", Memc[output]) + call wl_put_label_sides (WL_LABEL_SIDE(wd,1,AXIS2), Memc[output], + SZ_LINE) + call clppset (pp, "axis2_side", Memc[output]) + + # Close the pset. + call clcpset (pp) + + # Free memory. + call sfree (sp) +end + + +# WL_DESTROY -- Deallocate the WCSLAB descriptor. + +procedure wl_destroy (wd) + +pointer wd # I: the WCSLAB descriptor to be destroyed + +begin + # Deallocate all the subarrays. + call mfree (WL_WORLD_CENTER_PTR(wd), TY_DOUBLE) + call mfree (WL_TITLE_PTR(wd), TY_CHAR) + call mfree (WL_SCREEN_BOUNDARY_PTR(wd), TY_DOUBLE) + call mfree (WL_NV_PTR(wd), TY_REAL) + call mfree (WL_MIN_I_PTR(wd), TY_INT) + call mfree (WL_MAJ_I_PTR(wd), TY_DOUBLE) + call mfree (WL_LOGICAL_CENTER_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_VALUE_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_SIDE_PTR(wd), TY_BOOL) + call mfree (WL_LABEL_POSITION_PTR(wd), TY_DOUBLE) + call mfree (WL_LABEL_AXIS_PTR(wd), TY_INT) + call mfree (WL_LABEL_ANGLE_PTR(wd), TY_DOUBLE) + call mfree (WL_END_PTR(wd), TY_DOUBLE) + call mfree (WL_BEGIN_PTR(wd), TY_DOUBLE) + call mfree (WL_AXIS_TITLE_SIDE_PTR(wd), TY_BOOL) + call mfree (WL_AXIS_TITLE_PTR(wd), TY_CHAR) + + # Now deallocate the structure. + call mfree (wd, TY_STRUCT) +end + + +# WL_LABEL_SIDE -- Decode string into set of booleans sides. + +procedure wl_label_side (input, flag) + +char input[ARB] # I: string listing the sides to be labeled +bool flag[N_SIDES] # O: the flags indicating which sides wll be labeled + +int i +int strmatch() + +begin + # Initialize all the flags to false. + do i = 1, N_SIDES + flag[i] = false + + # Now set each side that is in the list. + if (strmatch (input, "right") != 0) + flag[RIGHT] = true + if (strmatch (input, "left") != 0) + flag[LEFT] = true + if (strmatch (input, "top") != 0) + flag[TOP] = true + if (strmatch (input, "bottom") != 0) + flag[BOTTOM] = true +end + + +# WL_STRING_TO_INTERVAL -- Convert from a string to a number. +# +# Description +# Since (ideally) the wcslab task should be able to handle any sky +# map transformation, there are a number of potential units that can be +# transformed from. The specification of coordinates in these systems +# are also quite varied. Thus, for input purposes, coordinates are entered +# as strings. This routine decodes the strings to a common unit (degrees) +# based on the type of system being graphed. +# +# Function Returns +# This returns the single coordinate value converted to a base system +# (degrees). + +double procedure wl_string_to_internal (input, axis_type, which_axis) + +char input[ARB] # I; the string containing the numerical value +int axis_type # I: the type of wcs +int which_axis # I: the axis number + +double value +int strlen(), nscan() + +begin + # It is possible that the value was not defined. + if (strlen (input) <= 0) + value = INDEFD + + # Decode based on the system. + else + switch (axis_type) { + + # The RA and DEC systems. + case RA_DEC: + + # Since SPP FMTIO can handle the HH:MM:SS format, just let it + # read in the value. However, there is no way to distinquish + # H:M:S from D:M:S. If the axis being read is RA, assume that + # it was H:M:S. + + call sscan (input) + call gargd (value) + + # If the axis is Longitude == RA, then convert the hours to + # degrees. + if (nscan() < 1) { + value = INDEFD + } else { + if (which_axis == AXIS1) + value = HRSTODEG (value) + } + + # Default- unknown system, just read the string as a double + # precision and return it. + default: + call sscan (input) + call gargd (value) + if (nscan() < 1) + value = INDEFD + } + + return (value) +end + + +# WL_LINE_TYPE -- Decode a string into an IRAF GIO polyline type. + +int procedure wl_line_type (line_type_string) + +char line_type_string[ARB] # I: the string specifying the line type + # "solid" -> GL_SOLID + # "dotted" -> GL_DOTTED + # "dashed" -> GL_DASHED + # "dotdash" -> GL_DOTDASH +int type +bool streq() + +begin + if (streq (line_type_string, "solid")) + type = GL_SOLID + else if (streq (line_type_string, "dotted")) + type = GL_DOTTED + else if (streq( line_type_string, "dashed")) + type = GL_DASHED + else if (streq (line_type_string, "dotdash")) + type = GL_DOTDASH + else { + call eprintf ("Pattern unknown, using 'solid'.\n") + type = GL_SOLID + } + + return (type) +end + + +# WL_INTERNAL_TO_STRING - Convert internal representation to a string. + +procedure wl_internal_to_string (value, system_type, which_axis, output) + +double value # I: the value to convert +int system_type # I: the wcs type +int which_axis # I: the axis +char output[ARB] # O: the output string + +begin + # If the value is undefined, write an empty string. + if (IS_INDEFD (value)) + output[1] = EOS + + # Else, convert the value depending on the axis types. + else + switch (system_type) { + + # Handle the RA, DEC + case RA_DEC: + + # If this is Axis1 == Right Ascension, then convert to hours. + if (which_axis == AXIS1) + value = value / 15.0D0 + + call sprintf (output, SZ_LINE, "%.6h") + call pargd (value) + + # Else, just write a value. + default: + call sprintf (output, SZ_LINE, "%.7g") + call pargd (value) + } + +end + + +# WL_SIDE_TO_STRING -- Convert a side to its string representation. + +procedure wl_side_to_string (side, output, max_len) + +int side # I: the side to convert +char output[max_len] # O: the string representation of the side +int max_len # I: the maximum length of the output string + +begin + switch (side) { + case RIGHT: + call strcpy ("right", output, max_len) + case LEFT: + call strcpy ("left", output, max_len) + case TOP: + call strcpy ("top", output, max_len) + case BOTTOM: + call strcpy ("bottom", output, max_len) + default: + call strcpy ("default", output, max_len) + } +end + + +# WL_PUT_LABEL_SIDES -- Create a string containing the sides specified. + +procedure wl_put_label_sides (side_flags, output, max_len) + +bool side_flags[N_SIDES] # I: the boolean array of sides +char output[ARB] # O: the output comma separated list of sides +int max_len # I: maximum length of the output string + +int i +pointer sp, side +int strlen() + +begin + # Get memory. + call smark (sp) + call salloc (side, max_len, TY_CHAR) + + # Build the list. + output[1] = EOS + do i = 1, N_SIDES + if (side_flags[i]) { + if (strlen (output) != 0) + call strcat (",", output, max_len) + call wl_side_to_string (i, Memc[side], max_len) + call strcat (Memc[side], output, max_len) + } + + if (strlen (output) == 0) + call strcat ("default", output, max_len) + + # Free memory. + call sfree (sp) +end diff --git a/pkg/images/tv/wcslab/wlgrid.x b/pkg/images/tv/wcslab/wlgrid.x new file mode 100644 index 00000000..4f457af4 --- /dev/null +++ b/pkg/images/tv/wcslab/wlgrid.x @@ -0,0 +1,448 @@ +include +include +include "wcslab.h" +include "wcs_desc.h" + + +# WL_GRID -- Put the grid lines/tick marks on the plot. +# +# Description +# Based on previously determined parameters., draw the grid lines and/or +# tick marks onto the graph. While in the process of doing this, create +# a list of possible label points for use by the label_grid routine. + +procedure wl_grid (wd) + +pointer wd # I: the WCSLAB descriptor + +double current, tmp_begin, tmp_end, tmp_minor_interval +int old_type, old_n_labels, min_counter +int gstati() + +begin + # Initialize the label counter. + WL_N_LABELS(wd) = 0 + + # Remember what line type is currently active. + old_type = gstati (WL_GP(wd), G_PLTYPE) + + # Determine integer range for axis 1. + tmp_minor_interval = WL_MAJOR_INTERVAL(wd,AXIS1) / + double (WL_MINOR_INTERVAL(wd,AXIS1)) + + # If near-polar, the lines should go all the way to the poles. + if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) + if (abs (WL_BEGIN(wd,AXIS2)) < abs (WL_END(wd,AXIS2))) { + tmp_begin = WL_BEGIN(wd,AXIS2) + tmp_end = NORTH_POLE_LATITUDE + } else { + tmp_begin = SOUTH_POLE_LATITUDE + tmp_end = WL_END(wd,AXIS2) + } + else { + tmp_begin = WL_BEGIN(wd,AXIS2) + tmp_end = WL_END(wd,AXIS2) + } + + # Plot lines of constant value in axis 1. + current = WL_BEGIN(wd,AXIS1) + min_counter = 0 + repeat { + + if (mod (min_counter, WL_MINOR_INTERVAL(wd,AXIS1)) == 0) { + call gseti (WL_GP(wd), G_PLTYPE, WL_MAJ_LINE_TYPE(wd)) + call wl_graph_constant_axis1 (wd, current, tmp_begin, tmp_end, + WL_MAJ_GRIDON(wd), WL_LABON(wd), WL_MAJ_TICK_SIZE(wd)) + } else { + call gseti (WL_GP(wd), G_PLTYPE, WL_MIN_LINE_TYPE(wd)) + call wl_graph_constant_axis1 (wd, current, tmp_begin, tmp_end, + WL_MIN_GRIDON(wd), NO, WL_MIN_TICK_SIZE(wd)) + } + + min_counter = min_counter + 1 + current = WL_BEGIN(wd,AXIS1) + tmp_minor_interval * min_counter + + } until (real (current) > real (WL_END(wd,AXIS1))) + + # Determine the interval range for the second axis. + tmp_minor_interval = WL_MAJOR_INTERVAL(wd,AXIS2) / + double (WL_MINOR_INTERVAL(wd,AXIS2)) + + # Plot lines of constant value in axis 2. + if (WL_END(wd,AXIS2) < WL_BEGIN(wd,AXIS2)) { + current = WL_END(wd,AXIS2) + tmp_minor_interval = -tmp_minor_interval + tmp_end = WL_BEGIN(wd,AXIS2) + } else { + current = WL_BEGIN(wd,AXIS2) + tmp_end = WL_END(wd,AXIS2) + } + + min_counter = 0 + tmp_begin = current + repeat { + if (mod (min_counter, WL_MINOR_INTERVAL(wd,AXIS2)) == 0) { + + call gseti (WL_GP(wd), G_PLTYPE, WL_MAJ_LINE_TYPE(wd)) + old_n_labels = WL_N_LABELS(wd) + call wl_graph_constant_axis2 (wd, current, WL_BEGIN(wd,AXIS1), + WL_END(wd,AXIS1), WL_MAJ_GRIDON(wd), WL_LABON(wd), + WL_MAJ_TICK_SIZE(wd)) + + # If this is a polar or near_polar plot, the latitudes + # should be placed near the line, not where it crosses the + # window boundary. + + if (WL_GRAPH_TYPE(wd) == POLAR && + (WL_MAJ_GRIDON(wd) == YES) && (WL_LABON(wd) == YES)) { + WL_N_LABELS(wd) = old_n_labels + 1 + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_POLAR_LABEL_POSITION(wd), current, + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),X_DIM), + WL_LABEL_POSITION(wd,WL_N_LABELS(wd),Y_DIM), 1) + WL_LABEL_VALUE(wd,WL_N_LABELS(wd)) = current + WL_LABEL_AXIS(wd,WL_N_LABELS(wd)) = AXIS2 + } + + } else { + call gseti (WL_GP(wd), G_PLTYPE, WL_MIN_LINE_TYPE(wd)) + call wl_graph_constant_axis2 (wd, current, WL_BEGIN(wd,AXIS1), + WL_END(wd,AXIS1), WL_MIN_GRIDON(wd), NO, + WL_MIN_TICK_SIZE(wd)) + } + + # Increment and continue + min_counter = min_counter + 1 + current = tmp_begin + tmp_minor_interval * min_counter + + } until (real (current) > real (tmp_end)) + + # Set the line type back to the way it was. + call gseti (WL_GP(wd), G_PLTYPE, old_type) +end + + +# WL_GRAPH_CONSTANT_AXIS1 - Graph lines of constant X-axis values. +# +# Description +# Because projections are rarely linear, the basic GIO interface to draw +# lines cannot be used. Instead, this routine handles the line drawing. +# Also, possible label points are found and added to a label list array. +# +# CLUDGE! Finding labels here is WRONG. Ideally, crossing points (where the +# line crosses a screen boundary) should be determined analytically. However, +# the MWCS interface lacks the required "cross-transformations". It can +# still be done, but requires a total bypassing of MWCS. Instead, this +# simplistic approach is used. + +procedure wl_graph_constant_axis1 (wd, x, ymin, ymax, gridon, label, tick_size) + +pointer wd # I: the WCSLAB descriptor +double x # I: X value to hold constant +double ymin, ymax # I: Y values to vary between +int gridon # I: true if gridding is on +int label # I: true if the points should be labelled +real tick_size # I: size of tick marks + +bool done +double lastx, lasty, lx, ly, y, yinc +real rlx, rly + +begin + # Determine the scale at which Y should be incremented. + yinc = (ymax - ymin) / WL_LINE_SEGMENTS(wd) + + # Now graph the line segments. + y = ymin + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lastx, lasty, 1) + + rlx = lastx + rly = lasty + call gamove (WL_GP(wd), rlx, rly) + + repeat { + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lx, ly, 1) + call wl_point_to_label (wd, lastx, lasty, lx, ly, AXIS1, x, gridon, + label, tick_size) + if (gridon == YES) { + rlx = lx + rly = ly + call gadraw (WL_GP(wd), rlx, rly) + } + if (yinc < 0.) + done = y < ymax + else + done = y > ymax + y = y + yinc + lastx = lx + lasty = ly + } until (done) +end + + +# WL_GRAPH_CONSTANT_AXIS2 -- Graph lines of constant Y-axis values. +# +# Description +# Because projections are rarely linear, the basic GIO interface to draw +# lines cannot be used. Instead, this routine handles the line drawing. +# Also, possible label points are found and added to an label list array. +# +# CLUDGE! Finding labels here is WRONG. Ideally, crossing points (where the +# line crosses a screen boundary) should be determined analytically. However, +# the MWCS interface lacks the required "cross-transformations". It can +# still be done, but requires a total bypassing of MWCS. Instead, this +# simplistic approach is used. + +procedure wl_graph_constant_axis2 (wd, y, xmin, xmax, gridon, label, tick_size) + +pointer wd # I: the WCSLAB descriptor +double y # I: Y value to hold constant +double xmin, xmax # I: X values to vary between +int gridon # I: true if gridding is on +int label # I: true if points should be labelled +real tick_size # I: tick mark size + +bool done +double lx, ly, lastx, lasty, x, xinc +real rlx, rly + +begin + # Determine the scale at which X should be incremented. + xinc = (xmax - xmin) / WL_LINE_SEGMENTS(wd) + + # Now graph the line segments. + x = xmin + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lastx, lasty, 1) + + rlx = lastx + rly = lasty + call gamove (WL_GP(wd), rlx, rly) + + repeat { + call wl_w2ld (WL_WLCT(wd), WL_AXIS_FLIP(wd), x, y, lx, ly, 1) + call wl_point_to_label (wd, lastx, lasty, lx, ly, AXIS2, y, gridon, + label, tick_size) + if (gridon == YES) { + rlx = lx + rly = ly + call gadraw (WL_GP(wd), rlx, rly) + } + if (xinc < 0.) + done = x < xmax + else + done = x > xmax + lastx = lx + lasty = ly + x = x + xinc + } until (done) +end + + +# Define the inside and outside of the window. + +define OUT (($1<=WL_SCREEN_BOUNDARY(wd,LEFT))||($1>=WL_SCREEN_BOUNDARY(wd,RIGHT))||($2<=WL_SCREEN_BOUNDARY(wd,BOTTOM))||($2>=WL_SCREEN_BOUNDARY(wd,TOP))) + +define IN (($1>WL_SCREEN_BOUNDARY(wd,LEFT))&&($1WL_SCREEN_BOUNDARY(wd,BOTTOM))&&($2 +include +include "wcslab.h" +include "wcs_desc.h" + + +# Define the offset array. +define OFFSET Memr[$1+$2-1] + +# WL_LABEL -- Place the labels on the grids. +# +# Description +# Format and write the labels for the grid/tick marks. Much of this +# is wading through conditions to decide whether a label should be +# written or not. + +procedure wl_label (wd) + +pointer wd # I: the WCSLAB descriptor + +bool no_side_axis1, no_side_axis2 +int i, axis1_side, axis2_side +pointer sp, offset_ptr +real offset + +begin + # Get some memory. + call smark (sp) + call salloc (offset_ptr, N_SIDES, TY_REAL) + do i = 1, N_SIDES + OFFSET(offset_ptr,i) = 0. + + # Decide whether any sides were specified for either axis. + no_side_axis1 = true + no_side_axis2 = true + do i = 1, N_SIDES { + if (WL_LABEL_SIDE(wd,i,AXIS1)) + no_side_axis1 = false + if (WL_LABEL_SIDE(wd,i,AXIS2)) + no_side_axis2 = false + } + + # If polar, then label the axis 2's next to their circles on the + # graph and allow the Axis 1s to be labeled on all sides of the graph. + + if (WL_GRAPH_TYPE(wd) == POLAR) { + + call wl_polar_label (wd) + + if (no_side_axis1) { + do i = 1, N_SIDES { + WL_LABEL_SIDE(wd,i,AXIS1) = true + } + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = BOTTOM + } + + # If we are near-polar, label the Axis 2 as if polar, and label + # Axis1 on all sides except the side closest to the pole. + + } else if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) { + + if (no_side_axis1) { + WL_LABEL_SIDE(wd,WL_BAD_LABEL_SIDE(wd),AXIS1) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS1))) + WL_AXIS_TITLE_SIDE(wd,AXIS1) = WL_BAD_LABEL_SIDE(wd) + } + + if (no_side_axis2) { + WL_LABEL_SIDE(wd,WL_POLAR_LABEL_DIRECTION(wd),AXIS2) = true + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = WL_POLAR_LABEL_DIRECTION(wd) + } + + # Final case- adjacent sides should be labelled. + + } else { + + # Determine the best sides for labelling. + if (INVERT (WL_ROTA(wd))) { + axis1_side = LEFT + axis2_side = BOTTOM + } else { + axis1_side = BOTTOM + axis2_side = LEFT + } + + # If no sides were specified, use the calculated ones above. + if (no_side_axis1) + WL_LABEL_SIDE(wd,axis1_side,AXIS1) = true + if (no_side_axis2) + WL_LABEL_SIDE(wd,axis2_side,AXIS2) = true + } + + # Now draw the labels for axis 1. + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS1)) { + call wl_lab_edges (wd, AXIS1, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(WD,AXIS1))) + WL_AXIS_TITLE_SIDE(WD,AXIS1) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Draw the labels for axis 2. + if (WL_GRAPH_TYPE(wd) != POLAR) + do i = 1, N_SIDES { + + if (WL_LABEL_SIDE(wd,i,AXIS2)) { + call wl_lab_edges (wd, AXIS2, i, offset) + if (IS_INDEFI (WL_AXIS_TITLE_SIDE(wd,AXIS2))) + WL_AXIS_TITLE_SIDE(wd,AXIS2) = i + } else + offset = 0. + + # Modify the bounding box for the new viewport. + if (abs (offset) > abs (OFFSET(offset_ptr,i))) + OFFSET(offset_ptr,i) = offset + } + + # Set the bounding box. + do i = 1, N_SIDES + WL_NEW_VIEW(wd,i) = WL_NEW_VIEW(wd,i) + OFFSET(offset_ptr,i) + + # Now write the graph title. + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS1), + WL_AXIS_TITLE_SIDE(wd,AXIS1), WL_AXIS_TITLE_SIZE(wd), + WL_NEW_VIEW(wd,1)) + if (WL_GRAPH_TYPE(wd) != POLAR) + call wl_title (WL_GP(wd), WL_AXIS_TITLE(wd,AXIS2), + WL_AXIS_TITLE_SIDE(wd,AXIS2), WL_AXIS_TITLE_SIZE(WD), + WL_NEW_VIEW(wd,1)) + if (! IS_INDEFI (WL_TITLE_SIDE(wd))) + call wl_title (WL_GP(wd), WL_TITLE(wd), WL_TITLE_SIDE(wd), + WL_TITLE_SIZE(wd), WL_NEW_VIEW(wd,1)) + + # Release memory. + call sfree (sp) +end + + +# Define what is in the screen. + +define IN (($1>WL_SCREEN_BOUNDARY(wd,LEFT))&&($1WL_SCREEN_BOUNDARY(wd,BOTTOM))&&($2= STTODEG (3600.0D0)) + prec = HOUR + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS1) >= STTODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } else { + if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (3600.0D0)) + prec = DEGREE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (60.0D0)) + prec = MINUTE + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (1.0D0)) + prec = SECOND + else if (WL_MAJOR_INTERVAL(wd,AXIS2) >= SATODEG (.01D0)) + prec = SUBSEC_LOW + else + prec = SUBSEC_HIGH + } + + # Handle other coordinate types. + else + prec = INDEFI + + return (prec) + +end + + +# Define some value constraints. + +define LOW_ACCURACY .01 +define HIGH_ACCURACY .0001 + +# WL_HMS -- Convert value to number in hours, minutes, and seconds. + +procedure wl_hms (rarad, hms, units, maxch, precision, all) + +double rarad # I: the value to format into a string (degrees) +char hms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be +bool all # I: true if all relevent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_hms, temp_units + +begin + # Get some memory. + call smark (sp) + call salloc (temp_hms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + hms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs(DEGTOST (rarad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = int (fraction + 0.5) + fraction = 0. + } + + # Range: 0 to 24 hours. + if (sec < 0) + sec = sec + STPERDAY + else if (sec >= STPERDAY) + sec = mod (sec, STPERDAY) + + # Separater fields. + s = mod (sec, 60) + m = mod (sec / 60, 60) + h = sec / 3600 + + # Format fields. + + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + fraction = s + fraction + if (precision == SUBSEC_LOW) { + call sprintf (hms, 6, "%05.2f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } else { + call sprintf (hms, 8, "%07.4f") + call pargd (fraction) + call strcpy (" s ", units, maxch) + } + if (!all) + all = (fraction < accuracy) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call sprintf (hms, 3, "%02d ") + call pargi (s) + call strcpy (" s", units, maxch) + if (! all) + all = (s == 0) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%02d ") + call pargi (m) + call strcpy (" m", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } else + all = (m == 0) + } + + # Non-zero hours. + if (precision == HOUR || all) { + if (all) { + call strcpy (hms, Memc[temp_hms], maxch) + call strcpy (units, Memc[temp_units], maxch) + } + call sprintf (hms, 3, "%2.2d ") + call pargi (h) + call strcpy(" h", units, maxch) + if (all) { + call strcat (Memc[temp_hms], hms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + } + + # Release memory + call sfree (sp) +end + + +# WL_DMS - Convert value to number in degrees, minutes, and seconds. + +procedure wl_dms (arcrad, dms, units, maxch, precision, all) + +double arcrad # I: the value to format into a string (degrees) +char dms[ARB] # O: string containing formatted value +char units[ARB] # O: string containing formatted units +int maxch # I: the maximum number of characters allowed +int precision # I: how precise the output should be ? +bool all # I: true if all relavent fields should be formatted + +double accuracy, fraction +int sec, h, m, s +pointer sp, temp_dms, temp_units +int strlen() + +begin + # Get some memory. + call smark (sp) + call salloc (temp_dms, maxch, TY_CHAR) + call salloc (temp_units, maxch, TY_CHAR) + + units[1] = EOS + dms[1] = EOS + + # Define how close to zero is needed. + accuracy = LOW_ACCURACY + if (precision == SUBSEC_HIGH) + accuracy = HIGH_ACCURACY + + # Seconds of time. + fraction = double (abs (DEGTOSA (arcrad))) + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + sec = int (fraction) + fraction = fraction - double (sec) + } else { + sec = nint (fraction) + fraction = 0. + } + + # Separater fields. + s = mod (abs(sec), 60) + m = mod (abs(sec) / 60, 60) + h = abs(sec) / 3600 + + # Format fields + # + # Subseconds. + if (precision == SUBSEC_LOW || precision == SUBSEC_HIGH) { + + fraction = s + fraction + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (precision == SUBSEC_LOW) { + call sprintf (dms, 6, "%05.2f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } else { + call sprintf (dms, 8, "%07.4f\"") + call pargd (fraction) + call strcpy (" ", units, maxch) + } + if (! all) + all = (fraction < accuracy) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + + # Seconds + } else if (precision == SECOND) { + + # NOTE: The all is not part of the if statement because if + # SUBSEC's have been printed, then seconds have already been + # dealt with. If SUBSEC's have not been dealt with, then this + # is the first field to be checked anyways. + + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d\"") + call pargi (s) + call strcpy (" ", units, maxch) + if (! all) + all = (s == 0) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Minutes. + if (precision == MINUTE || (precision > MINUTE && all)) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + call sprintf (dms, 3, "%02d'") + call pargi (m) + call strcpy (" ", units, maxch) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + if (! all) + all = (m == 0) + } + + # Hours. + if (precision == DEGREE || all) { + call strcpy (dms, Memc[temp_dms], maxch) + call strcpy (units, Memc[temp_units], maxch) + if (sec + fraction < accuracy) + call strcpy (" 0 ", dms, maxch) + else if (arcrad < 0.) { + call sprintf (dms, 4, "-%d ") + call pargi (h) + } else { + call sprintf (dms, 4, "+%d ") + call pargi (h) + } + call sprintf(units, 4, "%*wo") + call pargi (strlen (dms) - 1) + call strcat (Memc[temp_dms], dms, maxch) + call strcat (Memc[temp_units], units, maxch) + } + + # Release memory. + call sfree (sp) +end + + +# WL_FULL_LABEL_POSTION -- Find the position where the full label should be. +# +# Description +# This routine returns the index to the label that should be printed +# in its full form, regardless of its value. This is so there is always +# at least one labelled point with the full information. This point is +# choosen by examining which label is the closest to the passed point +# (usually one of the four corners of the display). +# +# Returns +# Index into the labell arrays of the label to be fully printed. +# If the return index is 0, then there are no labels for the given +# side. + +int procedure wl_full_label_position (wd, labels, nlabels, axis, side, + precision) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: array of indexes of labels to be printed +int nlabels # I: the number of labels in labels +int axis # I: the axis being dealt with +int side # I: the side being dealt with +int precision # I: precision of the label + +bool all +double cur_dist, dist +int i, cur_label, xside, yside +pointer sp, temp1 +double wl_distanced() + +begin + # Allocate some working space. + call smark (sp) + call salloc (temp1, SZ_LINE, TY_CHAR) + + # Initialize. + xside = INDEFI + yside = INDEFI + + # Determine which corner will have the full label. + if (side == TOP || side == BOTTOM) { + yside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS2)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS2)) + xside = LEFT + } else { + if (WL_LABEL_SIDE(wd,RIGHT,AXIS1)) + xside = RIGHT + if (WL_LABEL_SIDE(wd,LEFT,AXIS1)) + xside = LEFT + } + if (IS_INDEFI (xside)) + xside = LEFT + } else { + xside = side + if (axis == AXIS1) { + if (WL_LABEL_SIDE(wd,TOP,AXIS2)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS2)) + yside = BOTTOM + } else { + if (WL_LABEL_SIDE(wd,TOP,AXIS1)) + yside = TOP + if (WL_LABEL_SIDE(wd,BOTTOM,AXIS1)) + yside = BOTTOM + } + if (IS_INDEFI (yside)) + yside = BOTTOM + } + + # Find the full label. + cur_label = labels[1] + cur_dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,cur_label,AXIS1), + WL_LABEL_POSITION(wd,cur_label,AXIS2)) + + # Now go through the rest of the labels to find a closer label. + for (i = 2; i <= nlabels; i = i + 1) { + + # Check to see if the label would be written in full anyways. + all = false + if (WL_SYSTEM_TYPE(wd) == RA_DEC) { + if (WL_LABEL_AXIS(wd, labels[i]) == LONGITUDE) + call wl_hms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + else + call wl_dms (WL_LABEL_VALUE(wd, labels[i]), + Memc[temp1], Memc[temp1], SZ_LINE, precision, all) + } + + # If so, don't figure out which label should be full, there + # will be one someplace. + if (all) { + cur_label = INDEFI + break + } + + dist = wl_distanced (WL_SCREEN_BOUNDARY(wd,xside), + WL_SCREEN_BOUNDARY(wd,yside), + WL_LABEL_POSITION(wd,labels[i],AXIS1), + WL_LABEL_POSITION(wd,labels[i],AXIS2)) + if (dist < cur_dist) { + cur_dist = dist + cur_label = labels[i] + } + } + + # Release memory. + call sfree (sp) + + # Return the label index. + return (cur_label) +end + + +# WL_WRITE_LABEL - Write the label in the format specified by the WCS type. + +procedure wl_write_label (wd, value, side, x, y, angle, axis, precision, + do_full, offset) + +pointer wd # I: the WCSLAB descriptor +double value # I: the value to use as the label +int side # I: the side the label is going on +real x, y # I: position of the label in NDC coordinates +double angle # I: the angle the text should be written at +int axis # I: which axis is being labelled +int precision # I: level of precision for labels +bool do_full # I: true if the full label should be printed +real offset # I/O: offset for titles in NDC units + +int tside +pointer sp, label, label_format, units, units_format +real char_height, char_width, in_off_x, in_off_y, length +real lx, ly, new_offset, rx, ry, text_angle +real unit_off_x, unit_off_y, ux, uy + +bool fp_equalr() +double wl_string_angle() +int wl_opposite_side(), strlen() +real ggetr(), gstatr() + +begin + # Get some memory. + call smark (sp) + call salloc (label, SZ_LINE, TY_CHAR) + call salloc (units, SZ_LINE, TY_CHAR) + call salloc (label_format, SZ_LINE, TY_CHAR) + call salloc (units_format, SZ_LINE, TY_CHAR) + + # Get character size. This info is used to move the character string + # by the appropriate amounts. + + char_height = ggetr (WL_GP(wd), "ch") * gstatr (WL_GP(wd), G_TXSIZE) + char_width = ggetr (WL_GP(wd), "cw") * gstatr (WL_GP(wd), G_TXSIZE) + + # Determine the "corrected" angle to write text in. + text_angle = wl_string_angle (angle, WL_LABOUT(wd)) + + # Determine the units offset. + call wl_rotate (0., char_height / 2., 1, text_angle - 90., unit_off_x, + unit_off_y) + + # If the labels are to appear inside the graph and the major grid lines + # have been drawn, then determine the necessary offset to get the label + # off the line. + + if ((WL_LABOUT(wd) == NO) && (WL_MAJ_GRIDON(wd) == YES)) + call wl_rotate (0., 0.75 * char_height, 1, text_angle - 90., + in_off_x, in_off_y) + else { + in_off_x = 0. + in_off_y = 0. + } + + # Decode the coordinate into a text string. + switch (WL_SYSTEM_TYPE(wd)) { + case RA_DEC: + if (axis == LONGITUDE) + call wl_hms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + else + call wl_dms (value, Memc[label], Memc[units], SZ_LINE, + precision, do_full) + default: + call sprintf (Memc[label], SZ_LINE, "%.2g") + call pargd (value) + } + + # Set the text justification. + call sprintf (Memc[label_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + call sprintf (Memc[units_format], SZ_LINE, "h=c;v=c;u=%f") + call pargr (text_angle) + + # Determine offset needed to rotate text about the point of placement. + # NOTE: The STDGRAPH kernel messes up rotate text placement. Try to + # accomodate with extra offset. + + length = .5 * char_width * (2 + strlen (Memc[label])) + call wl_rotate (length, 0., 1, text_angle - 90., rx, ry) + rx = abs (rx) + ry = abs (ry) + + # If labels are to appear inside the graph, then justification should + # appear as if it were done for the opposite side. + if (WL_LABOUT(wd) == YES) + tside = side + else + tside = wl_opposite_side (side) + + # Now add the offsets appropriately. + switch (tside) { + case TOP: + ly = y + ry + in_off_y + unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly + unit_off_y + } else if (text_angle < 90.) + lx = x - rx + else + lx = x + rx + lx = lx + in_off_x + new_offset = ry + ry + + case BOTTOM: + ly = y - ry - in_off_y - unit_off_y + if (fp_equalr (text_angle, 90.)) { + lx = x + ly = ly - unit_off_y + } else if (text_angle < 90.) + lx = x + rx + else + lx = x - rx + lx = lx - in_off_x + new_offset = ry + ry + + case LEFT: + lx = x - rx - abs (unit_off_x) + if (text_angle < 90.) { + ly = y + ry - in_off_y + lx = lx - in_off_x + } else { + ly = y - ry + in_off_y + lx = lx + in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + + case RIGHT: + lx = x + rx + abs (unit_off_x) + if (text_angle < 90.) { + ly = y - ry + in_off_y + lx = lx + in_off_x + } else { + ly = y + ry - in_off_y + lx = lx - in_off_x + } + new_offset = rx + rx + abs (unit_off_x) + } + + lx = lx - (unit_off_x / 2.) + ly = ly - (unit_off_y / 2.) + ux = lx + unit_off_x + uy = ly + unit_off_y + + # Print the label. + call gtext (WL_GP(wd), lx, ly, Memc[label], Memc[label_format]) + + # Print the units (if appropriate). + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call gtext (WL_GP(wd), ux, uy, Memc[units], Memc[units_format]) + + # Determine new maximum string size. + if ((WL_LABOUT(wd) == YES) && (abs (offset) < new_offset)) + if (side == LEFT || side == BOTTOM) + offset = -new_offset + else + offset = new_offset + + # Release memory. + call sfree (sp) +end + + +# WL_STRING_ANGLE -- Produce the angle that a label string should be written to. +# +# Description +# Fixes the input angle so that the output angle is in the range 0 to 180. +# +# Returns +# the angle that the label should be written as. + +double procedure wl_string_angle (angle, right_to_up) + +double angle # I: the input angle in degrees +int right_to_up # I: true if angle near horizontal/vertical are fixed + +double output_angle + +begin + # Try to ensure that the angle is "upright", i.e. the string will not + # be printed upside-down. + + output_angle = angle + if (output_angle > QUARTER_CIRCLE) + output_angle = output_angle - HALF_CIRCLE + if (output_angle < -QUARTER_CIRCLE) + output_angle = output_angle + HALF_CIRCLE + + # If the angle is close to parallel with one of the axis, then just + # print it normally. + + if ((right_to_up == YES) && ((mod (abs (output_angle), + QUARTER_CIRCLE) < MIN_ANGLE) || (QUARTER_CIRCLE - + mod (abs (output_angle), QUARTER_CIRCLE) < MIN_ANGLE))) + output_angle = 0. + + # Return the angle modified for the idiocincracy of GIO text angle + # specification. + + return (output_angle + QUARTER_CIRCLE) +end + + +# WL_ANGLE -- Return the average angle of the labels in the list. +# +# Returns +# Average angle +# +# Description +# So that labels on a side are uniform (in some sense), the average angle +# of all the labels is taken and is defined as the angle that all the labels +# will be printed at. + +double procedure wl_angle (wd, labels, nlabels) + +pointer wd # I: the WCSLAB descriptor +int labels[nlabels] # I: the indexes of the labels to be printed out +int nlabels # I: the number of indexes in the list + +double total, average +int i + +begin + total = 0.0 + for (i = 1; i <= nlabels; i = i + 1) + total = total + WL_LABEL_ANGLE(wd,labels[i]) + average = real (total / nlabels) + + return (average) +end diff --git a/pkg/images/tv/wcslab/wlsetup.x b/pkg/images/tv/wcslab/wlsetup.x new file mode 100644 index 00000000..c37e24ca --- /dev/null +++ b/pkg/images/tv/wcslab/wlsetup.x @@ -0,0 +1,1000 @@ +include +include +include +include +include "wcslab.h" +include "wcs_desc.h" + +# WL_SETUP -- Determine all the basic characteristics of the plot. +# +# Description +# Determine basic characteristics of the plot at hand. This involved +# "discovering" what part of the world system covers the screen, the +# orientation of the world to logical systems, what type of graph will +# be produced, etc. Many of the parameters determined here can be +# over-ridden by user-specified values. + +procedure wl_setup (wd) + +pointer wd # I: the WCSLAB descriptor + +bool north +double array[N_EDGES,N_DIM], max_value[N_DIM], min_value[N_DIM] +double range[N_DIM], pole_position[N_DIM], view_edge[N_EDGES,N_DIM] +double wl_coord_rotation() +pointer mw_sctran() +string logtran "logical" +string wrldtran "world" + +begin + # Calculate the transformations from the Logical (pixel space) system + # to the World (possibly anything) system and back. + WL_LWCT(wd) = mw_sctran (WL_MW(wd), logtran, wrldtran, AXIS) + WL_WLCT(wd) = mw_sctran (WL_MW(wd), wrldtran, logtran, AXIS) + + # Indicate whether the center of the transformation is north. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + north = (WL_WORLD_CENTER(wd,LATITUDE) > 0.0D0) + + # Determine the poles position. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call wl_pole_position (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_WORLD_CENTER(wd,LONGITUDE), north, WL_SYSTEM_TYPE(wd), + pole_position) + + # Determine graph type based on the system type. + call wl_determine_graph_type (WL_SYSTEM_TYPE(wd), pole_position, + WL_SCREEN_BOUNDARY(wd,1), WL_GRAPH_TYPE(wd)) + + # Now find the extent of the WCS the window views, by constructing + # x,y vectors containing evenly spaced points around the edges of + # the viewing window. + + call wl_construct_edge_vectors (WL_SCREEN_BOUNDARY(wd,1), + view_edge[1,X_DIM], view_edge[1,Y_DIM], N_EDGES) + + # Find the range of the axes over the graphics viewport. + call wl_l2wd (WL_LWCT(wd), WL_AXIS_FLIP(wd), view_edge[1,X_DIM], + view_edge[1,Y_DIM], array[1,AXIS1], array[1,AXIS2], N_EDGES) + call alimd (array[1,AXIS1], N_EDGES, min_value[AXIS1], max_value[AXIS1]) + call alimd (array[1,AXIS2], N_EDGES, min_value[AXIS2], max_value[AXIS2]) + range[AXIS1] = abs (max_value[AXIS1] - min_value[AXIS1]) + range[AXIS2] = abs (max_value[AXIS2] - min_value[AXIS2]) + + # The above isn't good enough for the sky projections. Deal with those. + if (WL_SYSTEM_TYPE(wd) == RA_DEC) + call wl_sky_extrema (wd, array[1,AXIS1], N_EDGES, pole_position, + north, min_value[AXIS1], max_value[AXIS1], range[AXIS1], + min_value[AXIS2], max_value[AXIS2], range[AXIS2]) + + # Determine the rotation between the systems. + WL_ROTA(wd) = wl_coord_rotation (WL_WLCT(wd), WL_AXIS_FLIP(wd), + WL_WORLD_CENTER(wd,AXIS1), max_value[AXIS2], + WL_WORLD_CENTER(wd,AXIS1), min_value[AXIS2]) + + # Round the intervals. This is done to make the labelling "nice" and + # to smooth edge effects. + if (IS_INDEFD (WL_MAJOR_INTERVAL(wd,AXIS1)) || + IS_INDEFD (WL_BEGIN(wd,AXIS1)) || IS_INDEFD (WL_END(wd,AXIS1))) + call wl_round_axis (wd, AXIS1, min_value[AXIS1], max_value[AXIS1], + range[AXIS1]) + + if (IS_INDEFD (WL_MAJOR_INTERVAL(wd,AXIS2)) || + IS_INDEFD (WL_BEGIN(wd,AXIS2)) || IS_INDEFD (WL_END(wd,AXIS2))) + call wl_round_axis (wd, AXIS2, min_value[AXIS2], max_value[AXIS2], + range[AXIS2]) +end + + +# WL_POLE_POSITION -- Determine logical coordinates of a pole. +# +# Description +# Calculate the pole's position in the Logical system. +# +# Bugs +# Can only deal with Right Ascension/Declination. + +procedure wl_pole_position (wlct, flip, longitude, north, system_type, + pole_position) + +pointer wlct # I: the world-to-logical transformation +int flip # I: true if the axes are transposed +double longitude # I: the longitude to determine latitude +bool north # I: true if the pole is in the north +int system_type # I: type of system being examined +double pole_position[N_DIM] # O: the pole's logical coordinates + +double sgn + +begin + switch (system_type) { + + # For Right Ascension/Declination, the pole is at any longitude but + # at only 90 degrees (north) or -90 degrees (south) latitude. + case RA_DEC: + if (north) + sgn = NORTH_POLE_LATITUDE + else + sgn = SOUTH_POLE_LATITUDE + call wl_w2ld (wlct, flip, longitude, sgn, pole_position[X_DIM], + pole_position[Y_DIM], 1) + } + + # Sanity check on the pole position. It is very likely that there is + # no valid position in pixel space for the pole. This is checked for + # by looking for extremely large numbers. + if (abs (pole_position[X_DIM]) > abs (double (MAX_INT))) + pole_position[X_DIM] = real (MAX_INT) + if (abs (pole_position[Y_DIM]) > abs (double (MAX_INT))) + pole_position[Y_DIM] = real (MAX_INT) +end + + +# How close can the pole be to the center of the screen to be near-polar. +define HOW_CLOSE 3. + +# WL_DETERMINE_GRAPH_TYPE -- Determine the actual graph type. + +procedure wl_determine_graph_type (system_type, pole_position, + screen_boundary, graph_type) + +int system_type # I: the type of WCS being dealt with +double pole_position[N_DIM] # I: the location of the pole +double screen_boundary[N_SIDES] # I: the edges of the display +int graph_type # O: the graph type + +double max_dist, pole_dist, xcen, ycen + +begin + # Determine graph type based on axis type. + switch (system_type) { + + # If the pole is on the graph then force a graph_type of polar. + case RA_DEC: + + xcen = (screen_boundary[LEFT] + screen_boundary[RIGHT]) / 2. + ycen = (screen_boundary[BOTTOM] + screen_boundary[TOP]) / 2. + max_dist = min ((screen_boundary[LEFT] - xcen) ** 2, + (screen_boundary[TOP] - ycen)**2) + pole_dist = (pole_position[X_DIM] - xcen) ** 2 + + (pole_position[Y_DIM] - ycen) ** 2 + + # Check to see whether the graph is "polar", "near_polar" + # or "normal". If the pole lies within middle part of the + # viewport, then the graph is "polar". If the pole is within + # a certain maximum distance then it is "near_polar". + # Otherwise it is normal. + + switch (graph_type) { + case NORMAL: + # do nothing + case POLAR: + # do nothing + case NEAR_POLAR: + # do nothing + default: + if (pole_dist < max_dist) + graph_type = POLAR + else if (pole_dist < HOW_CLOSE * max_dist) + graph_type = NEAR_POLAR + else + graph_type = NORMAL + } + + # For all other cases, explicitely set this to normal. + default: + graph_type = NORMAL + } +end + + +# WL_CONSTRUCT_EDGE_VECTORS -- Construct vectors of values along window's edge. +# +# Description +# This routines filles two arrays, with the x-values and y-values of +# evenly spaced points along the edges of the screen. This is used to +# make transformation of the logical edges into the world system +# more convenient. + +procedure wl_construct_edge_vectors (screen_boundary, x, y, vector_size) + +double screen_boundary[N_SIDES] # I: the side values +double x[vector_size], y[vector_size] # O: the edge vector points +int vector_size # I: the number of edge vector points + +double current, interval +int i, left_over, offset1, offset2, side_length + +begin + # Divide the vectors into equal amounts for each side. + side_length = vector_size / N_SIDES + left_over = mod (vector_size, N_SIDES) + + # Calculate the horizontal components. + interval = (screen_boundary[RIGHT] - screen_boundary[LEFT]) / + side_length + current = screen_boundary[LEFT] + offset1 = side_length + for (i = 1; i <= side_length; i = i + 1) { + x[i] = current + interval + y[i] = screen_boundary[BOTTOM] + x[i+offset1] = current + y[i+offset1] = screen_boundary[TOP] + current = current + interval + } + + # Calculate the verticle components. + interval = (screen_boundary[TOP] - screen_boundary[BOTTOM]) / + side_length + current = screen_boundary[BOTTOM] + offset1 = 2 * side_length + offset2 = 3 * side_length + for (i = 1; i <= side_length; i = i + 1) { + x[i+offset1] = screen_boundary[LEFT] + y[i+offset1] = current + x[i+offset2] = screen_boundary[RIGHT] + y[i+offset2] = current + interval + current = current + interval + } + + # Fill in the left over with a single point. + offset1 = 4 * side_length + for (i = 1; i <= left_over; i = i + 1) { + x[i+offset1] = screen_boundary[LEFT] + y[i+offset1] = screen_boundary[BOTTOM] + } + +end + + +# WL_SKY_EXTREMA -- Determine what range the view window covers in the sky. +# This routine is only called if the WCS RA,DEC. +# +# Description +# Because of the different graph types and the fact that axis 1 usually +# wraps, more work needs to be done to determine what part of the sky +# is covered by the viewing window. + +procedure wl_sky_extrema (wd, ax1_array, n_points, pole_position, north, + ax1min, ax1max, ax1ran, ax2min, ax2max, ax2ran) + +pointer wd # I: the WCSLAB descriptor +double ax1_array[n_points] # I: the axis 1 edge vector +int n_points # I: the length of the edge vector +double pole_position[N_DIM] # I: the pole position +bool north # I: is the pole in the north ? +double ax1min, ax1max, ax1ran # I/O: the minimum, maximum, range in axis 1 +double ax2min, ax2max, ax2ran # I/O: the minimum, maximum, range in axis 2 + +bool is_pole +double nx, ny, xcen, ycen +int wl_direction_from_axis1(), wl_find_side(), wl_opposite_side() + +begin + # Is the pole on the graph ? + if ((pole_position[X_DIM] < WL_SCREEN_BOUNDARY(wd,LEFT)) || + (pole_position[X_DIM] > WL_SCREEN_BOUNDARY(wd,RIGHT)) || + (pole_position[Y_DIM] < WL_SCREEN_BOUNDARY(wd,BOTTOM)) || + (pole_position[Y_DIM] > WL_SCREEN_BOUNDARY(wd,TOP))) + is_pole = false + else + is_pole = true + + # If so adjust the RA and DEC ranges appropriately. + if (is_pole) { + + # Set the RA range. + ax1min = 0.0D0 + ax1max = 359.9D0 + ax1ran = 360.0D0 + + # Set the dec range. + if (north) + ax2max = NORTH_POLE_LATITUDE - ((NORTH_POLE_LATITUDE - + ax2min) * DISTANCE_TO_POLE ) + else + ax2min = SOUTH_POLE_LATITUDE + ((NORTH_POLE_LATITUDE + + ax2max) * DISTANCE_TO_POLE) + ax2ran = abs (ax2max - ax2min) + + # Mark the pole. + call gmark (WL_GP(wd), real (pole_position[X_DIM]), + real (pole_position[Y_DIM]), POLE_MARK_SHAPE, POLE_MARK_SIZE, + POLE_MARK_SIZE) + + } else { + # Only the RA range needs adjusting. + call wl_ra_range (ax1_array, n_points, ax1min, ax1max, ax1ran) + } + + # Adjust the labelling characteristics appropritatley for various + # types of graphs. + + if (WL_GRAPH_TYPE(wd) == POLAR) { + + # Determine which direction the axis 2's will be labeled on polar + # graphs. + if (IS_INDEFD (WL_POLAR_LABEL_POSITION(wd))) { + call wl_get_axis2_label_direction (WL_LWCT(wd), + WL_AXIS_FLIP(wd), pole_position, WL_SCREEN_BOUNDARY(wd,1), + WL_POLAR_LABEL_POSITION(wd), WL_BAD_LABEL_SIDE(wd)) + } else { + WL_BAD_LABEL_SIDE(wd) = wl_direction_from_axis1 (WL_WLCT(wd), + WL_AXIS_FLIP(wd), pole_position, north, + WL_POLAR_LABEL_POSITION(wd), WL_BEGIN(wd,AXIS2), + WL_END(wd,AXIS2), WL_SCREEN_BOUNDARY(wd,1)) + if (IS_INDEFI (WL_BAD_LABEL_SIDE(wd))) + WL_BAD_LABEL_SIDE(wd) = BOTTOM + } + + # If the graph type is polar, then determine how to justify + # the labels. + + if (IS_INDEFI (WL_POLAR_LABEL_DIRECTION(wd))) + WL_POLAR_LABEL_DIRECTION(wd) = + wl_opposite_side (WL_BAD_LABEL_SIDE(wd)) + + # If the graph_type is near-polar, then handle the directions a bit + # differently. + } else if (WL_GRAPH_TYPE(wd) == NEAR_POLAR) { + + # Find the side that the pole is on. + xcen = (WL_SCREEN_BOUNDARY(wd,LEFT) + + WL_SCREEN_BOUNDARY(wd,RIGHT)) / 2. + ycen = (WL_SCREEN_BOUNDARY(wd,BOTTOM) + + WL_SCREEN_BOUNDARY(wd,TOP)) / 2. + call wl_axis_on_line (xcen, ycen, pole_position[X_DIM], + pole_position[Y_DIM], WL_SCREEN_BOUNDARY(wd,1), nx, ny) + + if (IS_INDEFD(nx) || IS_INDEFD(ny)) { + WL_BAD_LABEL_SIDE(wd) = BOTTOM + WL_POLAR_LABEL_DIRECTION(wd) = LEFT + } else { + WL_BAD_LABEL_SIDE(wd) = wl_find_side (nx, ny, + WL_SCREEN_BOUNDARY(wd,1)) + if (WL_BAD_LABEL_SIDE(wd) == LEFT || WL_BAD_LABEL_SIDE(wd) == + RIGHT) + if (abs (ny - WL_SCREEN_BOUNDARY(wd,BOTTOM)) < + abs (ny - WL_SCREEN_BOUNDARY(wd,TOP))) + WL_POLAR_LABEL_DIRECTION(wd) = BOTTOM + else + WL_POLAR_LABEL_DIRECTION(wd) = TOP + else + if (abs (nx - WL_SCREEN_BOUNDARY(wd,LEFT)) < + abs (nx - WL_SCREEN_BOUNDARY(wd,RIGHT))) + WL_POLAR_LABEL_DIRECTION(wd) = LEFT + else + WL_POLAR_LABEL_DIRECTION(wd) = RIGHT + } + + } +end + + +# WL_COORD_ROTATION -- Determine "rotation" between the coordinate systems. +# +# Description +# This routine takes the world-to-logical coordinate transformation and +# two points in the world system which should define the positive verticle +# axis in the world system. These points are translated into the logical +# system and the angle between the logical vector and its positive verticle +# vector is calculated and returned. The rotation angle is returned +# in degrees and is always positive. + +double procedure wl_coord_rotation (wlct, flip, wx1, wy1, wx2, wy2) + +pointer wlct # I: the world-to-logical transformation +int flip # I: true if the coordinates are transposed +double wx1, wy1, wx2, wy2 # I: points in world space to figure rotation from + +double delx, dely, rota, x1, y1, x2, y2 +bool fp_equald() + +begin + # Transform the points to the logical system. + call wl_w2ld (wlct, flip, wx1, wy1, x1, y1, 1) + call wl_w2ld (wlct, flip, wx2, wy2, x2, y2, 1) + + # Determine the rotation. + delx = x2 - x1 + dely = y2 - y1 + if (fp_equald (delx, 0.0D0) && fp_equald (dely, 0.0D0)) + rota = 0. + else + rota = RADTODEG (atan2 (dely, delx)) + + if (rota < 0.0D0) + rota = rota + FULL_CIRCLE + + return (rota) +end + + +# Define how many axis one should go for. + +define RA_NUM_TRY 6 +define DEC_NUM_TRY 6 +define DEC_POLAR_NUM_TRY 4 + +# WL_ROUND_AXIS - Round values for the axis. + +procedure wl_round_axis (wd, axis, minimum, maximum, range) + +pointer wd # I: the WCSLAB descriptor +int axis # I: the axis being worked on +double minimum, maximum, range # I: raw values to be rounded + +int num_try + +begin + # Depending on axis type, round the values. + switch (WL_SYSTEM_TYPE(wd)) { + case RA_DEC: + if (axis == LONGITUDE) + call wl_round_ra (minimum, maximum, range, RA_NUM_TRY, + WL_BEGIN(wd,LONGITUDE), WL_END(wd,LONGITUDE), + WL_MAJOR_INTERVAL(wd,LONGITUDE)) + else { + if (WL_GRAPH_TYPE(wd) == POLAR) + num_try = DEC_POLAR_NUM_TRY + else + num_try = DEC_NUM_TRY + call wl_round_dec (minimum, maximum, range, num_try, + WL_BEGIN(wd,LATITUDE), WL_END(wd,LATITUDE), + WL_MAJOR_INTERVAL(wd,LATITUDE)) + } + + default: + call wl_generic_round (minimum, maximum, range, WL_BEGIN(wd,axis), + WL_END(wd,axis), WL_MAJOR_INTERVAL(wd,axis)) + } + +end + + +# WL_GET_AXIS2_LABEL_DIRECTION -- Dertermine label direction for latitides. +# +# Description +# Determine from which edge of the graph the axis 2 labels are to +# appear. This (in general) is the opposite edge from which the pole +# is nearest to. Move the pole to the closest edges, determine which +# side it is, then chose the direction as the opposite. Also determines +# the Axis 1 at which the Axis 2 labels will appear. + +procedure wl_get_axis2_label_direction (lwct, flip, pole_position, + screen_boundary, pole_label_position, bad_label_side) + +pointer lwct # I: logical-to-world transformation +int flip # I: true if the axis are transposed +double pole_position[N_DIM] # I: the position of the pole +double screen_boundary[N_SIDES] # I: the edges of the screen +double pole_label_position # O: the axis 1 that axis 2 labels should + # appear for polar|near-polar graphs +int bad_label_side # O: side not to place axis 1 labels + +double dif, tdif, dummy + +begin + # Determine which direction, up or down, the axis 2's will be labelled. + dif = abs (screen_boundary[TOP] - pole_position[AXIS2]) + bad_label_side= TOP + tdif = abs (screen_boundary[BOTTOM] - pole_position[AXIS2]) + if (tdif < dif) { + dif = tdif + bad_label_side = BOTTOM + } + + # Determine at what value of Axis 1 the Axis 2 labels should appear. + switch (bad_label_side) { + case TOP: + call wl_l2wd (lwct, flip, pole_position[AXIS1], + screen_boundary[BOTTOM], pole_label_position, dummy, 1) + case BOTTOM: + call wl_l2wd (lwct, flip, pole_position[AXIS1], + screen_boundary[TOP], pole_label_position, dummy, 1) + case LEFT: + call wl_l2wd (lwct, flip, screen_boundary[RIGHT], + pole_position[AXIS2], pole_label_position, dummy, 1) + case RIGHT: + call wl_l2wd (lwct, flip, screen_boundary[LEFT], + pole_position[AXIS2], pole_label_position, dummy, 1) + } + +end + + +# WL_DIRECTION_FROM_AXIS1 -- Determine axis 2 label direction from axis 1. +# +# Function Returns +# This returns the side where Axis 1 should not be labelled. + +int procedure wl_direction_from_axis1 (wlct, flip, pole_position, north, + polar_label_position, lbegin, lend, screen_boundary) + +pointer wlct # I: world-to-logical transformation +int flip # I: true if the axes are transposed +double pole_position[N_DIM] # I: the pole position +bool north # I: true if the pole is the north pole +double polar_label_position # I: the axis 1 where axis 2 will be + # marked +double lbegin # I: low end of axis 2 +double lend # I: high end of axis 2 +double screen_boundary[N_SIDES] # I: the window boundary + +double nx, ny, cx, cy +int wl_find_side() + +begin + # Determine the point in logical space where the axis 1 and the + # minimum axis 2 meet. + + if (north) + call wl_w2ld (wlct, flip, polar_label_position, lbegin, nx, ny, 1) + else + call wl_w2ld (wlct, flip, polar_label_position, lend, nx, ny, 1) + + # This line should cross a window boundary. Find that point. + + call wl_axis_on_line (pole_position[X_DIM], pole_position[Y_DIM], + screen_boundary, nx, ny, cx, cy) + + # Get the side that the crossing point is. This is the axis 2 labelling + # direction. + + if (IS_INDEFD(cx) || IS_INDEFD(cy)) + return (INDEFI) + else + return (wl_find_side (cx, cy, screen_boundary)) +end + + +# WL_OPPOSITE_SIDE - Return the opposite of the given side. +# +# Returns +# The opposite side of the specified side as follows: +# RIGHT -> LEFT +# LEFT -> RIGHT +# TOP -> BOTTOM +# BOTTOM -> TOP + +int procedure wl_opposite_side (side) + +int side # I: the side to find the opposite of + +int new_side + +begin + switch (side) { + case LEFT: + new_side = RIGHT + case RIGHT: + new_side = LEFT + case TOP: + new_side = BOTTOM + case BOTTOM: + new_side = TOP + } + + return (new_side) +end + + +# Define whether things are on the screen boundary or on them. + +define IN (($1>=screen_boundary[LEFT])&&($1<=screen_boundary[RIGHT])&&($2>=screen_boundary[BOTTOM])&&($2<=screen_boundary[TOP])) + + +# WL_AXIS_ON_LINE - Determine intersection of line and a screen boundary. +# +# Description +# Return the point where the line defined by the two input points +# crosses a screen boundary. The boundary is choosen by determining +# which one is between the two points. + +procedure wl_axis_on_line (x0, y0, x1, y1, screen_boundary, nx, ny) + +double x0, y0, x1, y1 # I: random points in space +double screen_boundary[N_SIDES] # I: sides of the window +double nx, ny # O: the closest point on a window boundary + +double x_val[N_SIDES], y_val[N_SIDES], tx0, ty0, tx1, ty1, w[2] +int i +pointer cvx, cvy +double dcveval() + +begin + # Get the line parameters. + x_val[1] = x0 + x_val[2] = x1 + y_val[1] = y0 + y_val[2] = y1 + + iferr (call dcvinit (cvx, CHEBYSHEV, 2, min (x0, x1), max (x0, x1))) + cvx = NULL + else { + call dcvfit (cvx, x_val, y_val, w, 2, WTS_UNIFORM, i) + if (i != OK) + call error (i, "wlaxie: Error solving on X") + } + + iferr (call dcvinit (cvy, CHEBYSHEV, 2, min (y0, y1), max (y0, y1))) + cvy = NULL + else { + call dcvfit (cvy, y_val, x_val, w, 2, WTS_UNIFORM, i) + if (i != OK) + call error (i, "wlaxie: Error solving on Y") + } + + # Solve for each side. + x_val[LEFT] = screen_boundary[LEFT] + if (cvx == NULL) + y_val[LEFT] = screen_boundary[LEFT] + else + y_val[LEFT] = dcveval (cvx, x_val[LEFT]) + + x_val[RIGHT] = screen_boundary[RIGHT] + if (cvx == NULL ) + y_val[RIGHT] = screen_boundary[RIGHT] + else + y_val[RIGHT] = dcveval (cvx, x_val[RIGHT]) + + y_val[TOP] = screen_boundary[TOP] + if (cvy == NULL) + x_val[TOP] = screen_boundary[TOP] + else + x_val[TOP] = dcveval (cvy, y_val[TOP]) + + y_val[BOTTOM] = screen_boundary[BOTTOM] + if (cvy == NULL) + x_val[BOTTOM] = screen_boundary[BOTTOM] + else + x_val[BOTTOM] = dcveval (cvy, y_val[BOTTOM]) + + # Rearrange the input points to be in ascending order. + if (x0 < x1) { + tx0 = x0 + tx1 = x1 + } else { + tx0 = x1 + tx1 = x0 + } + + if (y0 < y1) { + ty0 = y0 + ty1 = y1 + } else { + ty0 = y1 + ty1 = y0 + } + + # Now find which point is between the two given points and is within + # the viewing area. + # NOTE: Conversion to real for the check- if two points are so close + # for double, any of them would serve as the correct answer. + + nx = INDEFD + ny = INDEFD + for (i = 1; i <= N_SIDES; i = i + 1) + if (real (tx0) <= real (x_val[i]) && + real (x_val[i]) <= real (tx1) && + real (ty0) <= real (y_val[i]) && + real (y_val[i]) <= real (ty1) && + IN (x_val[i], y_val[i]) ) { + nx = x_val[i] + ny = y_val[i] + } + + # Release the curve fit descriptors. + if (cvx != NULL) + call dcvfree (cvx) + if (cvy != NULL) + call dcvfree (cvy) +end + + +# WL_FIND_SIDE -- Return the side that the given point is lying on. +# +# Function Returns +# Return the side, TOP, BOTTOM, LEFT, or RIGHT, that the specified +# point is lying on. One of the coordinates must be VERY CLOSE to one of +# the sides or INDEFI will be returned. + +int procedure wl_find_side (x, y, screen_boundary) + +double x, y # I: the point to inquire about +double screen_boundary[N_SIDES] # I: the edges of the screen + +double dif, ndif +int side + +begin + dif = abs (x - screen_boundary[LEFT]) + side = LEFT + + ndif = abs (x - screen_boundary[RIGHT]) + if (ndif < dif) { + side = RIGHT + dif = ndif + } + + ndif = abs (y - screen_boundary[BOTTOM]) + if (ndif < dif) { + side = BOTTOM + dif = ndif + } + + ndif = abs (y - screen_boundary[TOP]) + if (ndif < dif) + side = TOP + + return (side) +end + + +# WL_RA_RANGE -- Determine the range in RA given a list of possible values. +# +# Description +# Determine the largest range in RA from the provided list of values. +# The problem here is that it is unknown which way the graph is oriented. +# To simplify the problem, it is assume that the graph range does not extend +# beyond a hemisphere and that all distances in RA is less than a hemisphere. +# This assumption is needed to decide when the 0 hour is on the graph. + +procedure wl_ra_range (ra, n_values, min, max, diff) + +double ra[ARB] # I: the possible RA values +int n_values # I: the number of possible RA values +double min # I/O: the minimum RA +double max # I/O: the maximum RA +double diff # I/O: the difference between minimum and maximum + +bool wrap +int i, j, n_diffs +pointer sp, max_array, min_array, ran_array +int wl_max_element_array() + +begin + call smark (sp) + call salloc (max_array, n_values * n_values, TY_DOUBLE) + call salloc (min_array, n_values * n_values, TY_DOUBLE) + call salloc (ran_array, n_values * n_values, TY_DOUBLE) + + # Check whether the RA is wrapped or not. + n_diffs = 0 + do i = 1, n_values { + if (ra[i] >= min && ra[i] <= max) + next + n_diffs = n_diffs + 1 + } + if (n_diffs > 0) + wrap = true + else + wrap = false + + n_diffs = 0 + for (i = 1; i <= n_values; i = i + 1) { + for (j = i + 1; j <= n_values; j = j + 1) { + n_diffs = n_diffs + 1 + call wl_getradif (ra[i], ra[j], Memd[min_array+n_diffs-1], + Memd[max_array+n_diffs-1], Memd[ran_array+n_diffs-1], + wrap) + } + } + + i = wl_max_element_array (Memd[ran_array], n_diffs) + min = Memd[min_array+i-1] + max = Memd[max_array+i-1] + diff = Memd[ran_array+i-1] + + call sfree (sp) +end + + +# WL_GETRADIFF -- Get differences in RA based on degrees. +# +# Description +# This procedure determines, given two values in degrees, the minimum, +# maximum, and difference of those values. The assumption is that no +# difference should be greater than half a circle. Based on this assumption, +# a difference is found and the minimum and maximum are determined. The +# maximum can be greater than 360 degrees. + +procedure wl_getradif (val1, val2, min, max, diff, wrap) + +double val1, val2 # I: the RA values +double min, max # O: the min RA and max RA (possibly > 360.0) +double diff # O: the min, max difference +bool wrap # I: is the ra wrapped ? + +begin + if (! wrap && (abs (val1 - val2) > HALF_CIRCLE)) + if (val1 < val2) { + min = val2 + max = val1 + FULL_CIRCLE + } else { + min = val1 + max = val2 + FULL_CIRCLE + } + else + if (val1 < val2) { + min = val1 + max = val2 + } else { + min = val2 + max = val1 + } + diff = max - min +end + + +define NRAGAP 26 + +# WL_ROUND_RA -- Modify the RA limits and calculate an interval to label. +# +# Description +# The RA limits determine by just the extremes of the window ususally do +# not fall on "reasonable" boundaries; i.e. essentially they are random +# numbers. However, for labelling purposes, it is nice to have grids and +# tick marks for "rounded" numbers- For RA, this means values close to +# whole hours, minutes, or seconds. For example, if the span across the +# plot is a few hours, the marks and labels should represent simply whole +# hours. This routine determines new RA limits based on this and some +# interval to produce marks between the newly revised limits. + +procedure wl_round_ra (longmin, longmax, longran, num_try, minimum, maximum, + major_interval) + +double longmin # I: longitude minimum +double longmax # I: longitude maximum +double longran # I: longitude range +int num_try # I: the number of intervals to try for +double minimum # O: the minimum RA value (in degrees) +double maximum # O: the maximum RA value (in degrees) +double major_interval # O: the appropriate interval (in degrees) for the + # major line marks. + +double ragap[NRAGAP] +double wl_check_arrayd(), wl_round_upd() +data ragap / 1.0D-4, 2.0D-4, 5.0D-4, 1.0D-3, 2.0D-3, 5.0D-3, + 0.01D0, 0.02D0, 0.05D0, 0.1D0, 0.2D0, 0.5D0, 1.0D0, + 2.0D0, 5.0D0, 10.0D0, 20.0D0, 30.0D0, 60.0D0, 120.0D0, + 300.0D0, 600.0D0, 1.2D3, 1.8D3, 3.6D3, 7.2D3 / + + +begin + major_interval = wl_check_arrayd (DEGTOST (longran) / num_try, + ragap, NRAGAP) + minimum = STTODEG (wl_round_upd (DEGTOST (longmin), major_interval) - + major_interval) + maximum = STTODEG (wl_round_upd (DEGTOST (longmax), major_interval)) + major_interval = STTODEG (major_interval) +end + + +define NDECGAP 28 + +# WL_ROUND_DEC -- Modify the DEC limits and calculate an interval to label. +# +# Description +# The DEC limits determine by just the extremes of the window ususally do +# not fall on "reasonable" boundaries; i.e. essentially they are random +# numbers. However, for labelling purposes, it is nice to have grids and +# tick marks for "rounded" numbers- For DEC, this means values close to +# whole degrees, minutes, or seconds. For example, if the span across the +# plot is a few degrees, the marks and labels should represent simply whole +# degrees. This routine determines new DEC limits based on this and some +# interval to produce marks between the newly revised limits. + +procedure wl_round_dec (latmin, latmax, latran, num_try, minimum, maximum, + major_interval) + +double latmin # I: the latitude minimum +double latmax # I: the latitude maximum +double latran # I: the latitude range +int num_try # I: number of intervals to try for +double minimum # O: the DEC minimum +double maximum # O: the DEC maximum +double major_interval # O: the labelling interval to use for major lines + +double decgap[NDECGAP] +double wl_check_arrayd(), wl_round_upd() +data decgap / 1.0D-4, 2.0D-4, 5.0D-4, 1.0D-3, 2.0D-3, 5.0D-3, + 0.01D0, 0.02D0, 0.05D0, 0.1D0, 0.2D0, 0.5D0, 1.0D0, + 2.0D0, 5.0D0, 10.0D0,20.0D0, 30.0D0, 60.0D0, 120.0d0, + 300.0D0, 600.0D0, 1.2D3, 1.8D3, 3.6D3, 7.2D3, 1.8D4, 3.6D4 / + +begin + major_interval = wl_check_arrayd (DEGTOSA (latran) / num_try, + decgap, NDECGAP) + minimum = SATODEG (wl_round_upd (DEGTOSA (latmin), major_interval) - + major_interval) + maximum = SATODEG (wl_round_upd (DEGTOSA (latmax), major_interval)) + major_interval = SATODEG (major_interval) + + # Make sure that the grid marking does not include the pole. + maximum = min (maximum, NORTH_POLE_LATITUDE - major_interval) + minimum = max (minimum, SOUTH_POLE_LATITUDE + major_interval) +end + + +# WL_GENERIC_ROUND -- Round the values (if possible). +# +# History +# 7Feb91 - Created by Jonathan D. Eisenhamer, STScI. + +procedure wl_generic_round (minimum, maximum, range, lbegin, lend, interval) + +double minimum, maximum, range # I: the raw input values +double lbegin, lend # O: the begin and end label points +double interval # O: the major label interval + +double amant, diff +int iexp, num +double wl_round_upd() + +begin + diff = log10 (abs (range) / 4.D0) + iexp = int (diff) + if (diff < 0) + iexp = iexp - 1 + + amant = diff - double (iexp) + if (amant < 0.15D0) + num = 1 + else if (amant < 0.50D0) + num = 2 + else if (amant < 0.85D0) + num = 5 + else + num = 10 + + interval = double (num) * 10.0D0 ** iexp + lbegin = wl_round_upd (minimum, interval) - interval + lend = wl_round_upd (maximum, interval) +end + + +# WL_ROUND_UPD -- Round X up to nearest whole multiple of Y. + +double procedure wl_round_upd (x, y) + +double x # I: value to be rounded +double y # I: multiple of X is to be rounded up in + +double z, r + +begin + if (x < 0.0D0) + z = 0.0D0 + else + z = y + r = y * double (int ((x + z) / y)) + + return (r) +end + + + +# WL_CHECK_ARRAYD -- Check proximity of array elements to each other. +# +# Description +# Returns the element of the array arr(n) which is closest to an exact +# value EX. + +double procedure wl_check_arrayd (ex, arr, n) + +double ex # I: the exact value +double arr[ARB] # I: the array of rounded values +int n # I: dimension of array of rounded values + +int j + +begin + for (j = 1; j < n && (ex - arr[j]) > 0.0D0; j = j + 1) + ; + if (j > 1 && j < n) + if (abs (ex - arr[j-1]) < abs (ex - arr[j])) + j = j - 1 + + return (arr[j]) +end diff --git a/pkg/images/tv/wcslab/wlutil.x b/pkg/images/tv/wcslab/wlutil.x new file mode 100644 index 00000000..c79b8f5e --- /dev/null +++ b/pkg/images/tv/wcslab/wlutil.x @@ -0,0 +1,390 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include + +# WL_IMD_VIEWPORT -- Map the viewport and window of the image display. + +procedure wl_imd_viewport (frame, im, c1, c2, l1, l2, vl, vr, vb, vt) + +int frame # I: display frame to be overlayed +pointer im # I: pointer to the input image +real c1, c2, l1, l2 # I/O: input/output window +real vl, vr, vb, vt # I/O: input/output viewport + +int wcs_status, dim1, dim2, step1, step2 +pointer sp, frimage, frim, iw +real x1, x2, y1, y2, fx1, fx2, fy1, fy2, junkx, junky +real vx1, vx2, vy1, vy2, nx1, nx2, ny1, ny2 +pointer imd_mapframe(), iw_open() + + +begin + # If all of the viewport parameters were defined by the user + # use the default viewport and window. + if (! IS_INDEFR(vl) && ! IS_INDEFR(vr) && ! IS_INDEFR(vb) && + ! IS_INDEFR(vt)) + return + + # Allocate some memory. + call smark (sp) + call salloc (frimage, SZ_FNAME, TY_CHAR) + + # Open the requested display frame and get the loaded image name. + # If this name is blank, use the default viewport and window. + + frim = imd_mapframe (frame, READ_ONLY, YES) + iw = iw_open (frim, frame, Memc[frimage], SZ_FNAME, wcs_status) + if (Memc[frimage] == EOS || wcs_status == ERR) { + call iw_close (iw) + call imunmap (frim) + call sfree (sp) + return + } + + # Find the beginning and end points of the requested image section. + # We already know at this point that the input logical image is + # 2-dimensional. However this 2-dimensional section may be part of + # n-dimensional image. + + # X dimension. + dim1 = IM_VMAP(im,1) + step1 = IM_VSTEP(im,1) + if (step1 >= 0) { + x1 = IM_VOFF(im,dim1) + 1 + x2 = x1 + IM_LEN(im,1) - 1 + } else { + x1 = IM_VOFF(im,dim1) - 1 + x2 = x1 - IM_LEN(im,1) + 1 + } + + # Y dimension. + dim2 = IM_VMAP(im,2) + step2 = IM_VSTEP(im,2) + if (step2 >= 0) { + y1 = IM_VOFF(im,dim2) + 1 + y2 = y1 + IM_LEN(im,2) - 1 + } else { + y1 = IM_VOFF(im,dim2) - 1 + y2 = y1 - IM_LEN(im,2) + 1 + } + + # Get the frame buffer coordinates corresponding to the lower left + # and upper right corners of the image section. + + call iw_im2fb (iw, x1, y1, fx1, fy1) + call iw_im2fb (iw, x2, y2, fx2, fy2) + if (fx1 > fx2) { + junkx = fx1 + fx1 = fx2 + fx2 = junkx + } + if (fy1 > fy2) { + junky = fy1 + fy1 = fy2 + fy2 = junky + } + + # Check that some portion of the input image is in the display. + # If not select the default viewport and window coordinates. + if (fx1 > IM_LEN(frim,1) || fx2 < 1.0 || fy1 > IM_LEN(frim,2) || + fy2 < 1.0) { + call iw_close (iw) + call imunmap (frim) + call sfree (sp) + return + } + + # Compute a new viewport and window for X. + if (fx1 >= 1.0) { + vx1 = max (0.0, min (1.0, (fx1 - 0.5) / IM_LEN(frim,1))) + nx1 = 1.0 + } else { + vx1 = 0.0 + call iw_fb2im (iw, 1.0, 1.0, junkx, junky) + if (step1 >= 0) + nx1 = max (1.0, junkx - x1 + 1.0) + else + nx2 = max (1.0, junkx - x2 + 1.0) + } + if (fx2 <= IM_LEN(frim,1)) { + vx2 = max (0.0, min (1.0, (fx2 + 0.5) / IM_LEN(frim,1))) + nx2 = IM_LEN(im,1) + } else { + vx2 = 1.0 + call iw_fb2im (iw, real(IM_LEN(frim,1)), real (IM_LEN(frim,2)), + junkx, junky) + if (step1 >= 0) + nx2 = min (real (IM_LEN(im,1)), junkx - x1 + 1.0) + else + nx1 = min (real (IM_LEN(im,1)), junkx - x2 + 1.0) + } + + # Compute a new viewport and window for Y. + if (fy1 >= 1.0) { + vy1 = max (0.0, min (1.0, (fy1 - 0.5) / IM_LEN(frim,2))) + ny1 = 1.0 + } else { + vy1 = 0.0 + call iw_fb2im (iw, 1.0, 1.0, junkx, junky) + if (step2 >= 0) + ny1 = max (1.0, junky - y1 + 1) + else + ny2 = max (1.0, junky - y2 + 1) + } + if (fy2 <= IM_LEN(frim,2)) { + vy2 = max (0.0, min (1.0, (fy2 + 0.5) / IM_LEN(frim,2))) + ny2 = IM_LEN(im,2) + } else { + vy2 = 1.0 + call iw_fb2im (iw, real (IM_LEN(frim,1)), real (IM_LEN(frim,2)), + junkx, junky) + if (step2 >= 0) + ny2 = min (real (IM_LEN(im,2)), junky - y1 + 1.0) + else + ny1 = min (real (IM_LEN(im,2)), junky - y2 + 1.0) + } + + # Define a the new viewport and window. + if (IS_INDEFR(vl)) { + vl = vx1 + c1 = nx1 + } + if (IS_INDEFR(vr)) { + vr = vx2 + c2 = nx2 + } + if (IS_INDEFR(vb)) { + vb = vy1 + l1 = ny1 + } + if (IS_INDEFR(vt)) { + vt = vy2 + l2 = ny2 + } + + # Clean up. + call iw_close (iw) + call imunmap (frim) + call sfree (sp) +end + + +define EDGE1 0.1 +define EDGE2 0.9 +define EDGE3 0.12 +define EDGE4 0.92 + +# WL_MAP_VIEWPORT -- Set device viewport wcslab plots. If not specified by +# user, a default viewport centered on the device is used. + +procedure wl_map_viewport (gp, c1, c2, l1, l2, ux1, ux2, uy1, uy2, fill) + +pointer gp # I: pointer to graphics descriptor +real c1, c2, l1, l2 # I: the column and line limits +real ux1, ux2, uy1, uy2 # I/O: NDC coordinates of requested viewort +bool fill # I: fill viewport (vs preserve aspect ratio) + +int ncols, nlines +real xcen, ycen, ncolsr, nlinesr, ratio, aspect_ratio +real x1, x2, y1, y2, ext, xdis, ydis +bool fp_equalr() +real ggetr() +data ext /0.0625/ + +begin + ncols = nint (c2 - c1) + 1 + ncolsr = real (ncols) + nlines = nint (l2 - l1) + 1 + nlinesr = real (nlines) + + # Determine the standard window sizes. + if (fill) { + x1 = 0.0; x2 = 1.0 + y1 = 0.0; y2 = 1.0 + } else { + x1 = EDGE1; x2 = EDGE2 + y1 = EDGE3; y2 = EDGE4 + } + + # If any values were specified, then replace them here. + if (! IS_INDEFR(ux1)) + x1 = ux1 + if (! IS_INDEFR(ux2)) + x2 = ux2 + if (! IS_INDEFR(uy1)) + y1 = uy1 + if (! IS_INDEFR(uy2)) + y2 = uy2 + + # Calculate optimum viewport, as in NCAR's conrec, hafton. + if (! fill) { + ratio = min (ncolsr, nlinesr) / max (ncolsr, nlinesr) + if (ratio >= ext) { + if (ncols > nlines) + y2 = (y2 - y1) * nlinesr / ncolsr + y1 + else + x2 = (x2 - x1) * ncolsr / nlinesr + x1 + } + } + + xdis = x2 - x1 + ydis = y2 - y1 + xcen = (x2 + x1) / 2. + ycen = (y2 + y1) / 2. + + # So far, the viewport has been calculated so that equal numbers of + # image pixels map to equal distances in NDC space, regardless of + # the aspect ratio of the device. If the parameter "fill" has been + # set to no, the user wants to compensate for a non-unity aspect + # ratio and make equal numbers of image pixels map to into the same + # physical distance on the device, not the same NDC distance. + + if (! fill) { + aspect_ratio = ggetr (gp, "ar") + if (fp_equalr (aspect_ratio, 0.0)) + aspect_ratio = 1.0 + + if (aspect_ratio < 1.0) + # Landscape + xdis = xdis * aspect_ratio + else if (aspect_ratio > 1.0) + # Portrait + ydis = ydis / aspect_ratio + } + + ux1 = xcen - (xdis / 2.0) + ux2 = xcen + (xdis / 2.0) + uy1 = ycen - (ydis / 2.0) + uy2 = ycen + (ydis / 2.0) + + call gsview (gp, ux1, ux2, uy1, uy2) + call gswind (gp, c1, c2, l1, l2) +end + + +# WL_W2LD -- Transform world coordinates to logical coordinates. + +procedure wl_w2ld (wlct, flip, wx, wy, lx, ly, npts) + +pointer wlct # I: the MWCS coordinate transformation descriptor +int flip # I: true if the axes are transposed +double wx[npts], wy[npts] # I: the world coordinates +double lx[npts], ly[npts] # O: the logical coordinates +int npts # I: the number of points to translate + +begin + if (flip == YES) + call mw_v2trand (wlct, wx, wy, ly, lx, npts) + else + call mw_v2trand (wlct, wx, wy, lx, ly, npts) +end + + +# WL_L2WD -- Transform logical coordinates to world coordinates. + +procedure wl_l2wd (lwct, flip, lx, ly, wx, wy, npts) + +pointer lwct # I: the MWCS coordinate transformation descriptor +int flip # I: true if the axes are transposed +double lx[npts], ly[npts] # I: the logical coordinates +double wx[npts], wy[npts] # O: the world coordinates +int npts # I: the number of points to translate + +begin + if (flip == YES) + call mw_v2trand (lwct, ly, lx, wx, wy, npts) + else + call mw_v2trand (lwct, lx, ly, wx, wy, npts) +end + + +# WL_MAX_ELEMENT_ARRAY -- Return the index of the maximum array element. +# +# Description +# This function returns the index of the maximum value of the input array. + +int procedure wl_max_element_array (array, npts) + +double array[ARB] # I: the array to look through for the maximum +int npts # I: the number of points in the array + +int i, maximum + +begin + maximum = 1 + for (i = 2; i <= npts; i = i + 1) + if (array[i] > array[maximum]) + maximum = i + + return (maximum) +end + + +# WL_DISTANCED - Determine the distance between two points. + +double procedure wl_distanced (x1, y1, x2, y2) + +double x1, y1 # I: coordinates of point 1 +double x2, y2 # I: coordinates of point 2 + +double a, b + +begin + a = x1 - x2 + b = y1 - y2 + return (sqrt ((a * a) + (b * b))) +end + + +# WL_DISTANCER -- Determine the distance between two points. + +real procedure wl_distancer (x1, y1, x2, y2) + +real x1, y1 # I: coordinates of point 1 +real x2, y2 # I: coordinates of point 2 + +real a, b + +begin + a = x1 - x2 + b = y1 - y2 + return (sqrt ((a * a) + (b * b))) +end + + +# The dimensionality. +define N_DIM 2 + +# Define some memory management. +define ONER Memr[$1+$2-1] + +# WL_ROTATE -- Rotate a vector. + +procedure wl_rotate (x, y, npts, angle, nx, ny) + +real x[npts], y[npts] # I: the vectors to rotate +int npts # I: the number of points in the vectors +real angle # I: the angle to rotate (radians) +real nx[npts], ny[npts] # O: the transformed vectors + +pointer sp, center, mw +pointer mw_open(), mw_sctran() + +begin + # Get some memory. + call smark (sp) + call salloc (center, N_DIM, TY_REAL) + + mw = mw_open (NULL, N_DIM) + ONER(center,1) = 0. + ONER(center,2) = 0. + call mw_rotate (mw, -DEGTORAD( angle ), ONER(center,1), 3b) + call mw_v2tranr (mw_sctran (mw, "physical", "logical", 3b), + x, y, nx, ny, npts) + + call mw_close (mw) + call sfree (sp) +end diff --git a/pkg/images/tv/wcslab/wlwcslab.x b/pkg/images/tv/wcslab/wlwcslab.x new file mode 100644 index 00000000..1547f568 --- /dev/null +++ b/pkg/images/tv/wcslab/wlwcslab.x @@ -0,0 +1,181 @@ +include +include +include "wcslab.h" +include "wcs_desc.h" + +# Define the memory structure for saving the graphics wcs. +define SAVE_BLOCK_SIZE 16 +define OLD_NDC_VIEW Memr[P2R(wcs_save_block-1+$1)] +define OLD_NDC_WIND Memr[P2R(wcs_save_block+3+$1)] +define OLD_PLT_VIEW Memr[P2R(wcs_save_block+7+$1)] +define OLD_PLT_WIND Memr[P2R(wcs_save_block+11+$1)] + +# WL_WCSLAB -- Label using a defined wcs. +# +# Description +# This routine uses the information in the WCSLAB descriptor to perform +# labelling. +# +# Before this routine can be called, several things must have already +# occured. They are as follows: +# 1 A call to wl_create must be made to create the WCSLAB descriptor. +# 2 The WCS_MW component must be set to the MWCS object of the +# desired transformations. +# 3 A call to wl_get_system_type must be made. +# 4 The graphics device must have been opened and the window defined. +# The WCS_GP component of the WCSLAB descriptor must be set to the +# graphics window descriptor. +# +# When done with this routine, the WL_GP and WL_MW components must be +# deallocated seperately. Then only wlab_destroy need be called to +# remove the WCSLAB descriptor. +# +#--------------------------------------------------------------------------- + +procedure wl_wcslab (wd) + +pointer wd # I: the WCSLAB descriptor + +int old_clip, old_pltype, old_txquality, old_wcs +pointer sp, wcs_save_block +real old_plwidth, old_txsize, old_txup +int gstati() +real gstatr() + +begin + # Allocate working space. + call smark(sp) + call salloc(wcs_save_block, SAVE_BLOCK_SIZE, TY_STRUCT) + + # Store certain graphics parameters. + old_plwidth = gstatr (WL_GP(wd), G_PLWIDTH) + old_txsize = gstatr (WL_GP(wd), G_TXSIZE) + old_txup = gstatr (WL_GP(wd), G_TXUP) + old_clip = gstati (WL_GP(wd), G_CLIP) + old_pltype = gstati (WL_GP(wd), G_PLTYPE) + old_txquality= gstati (WL_GP(wd), G_TXQUALITY) + old_wcs = gstati (WL_GP(wd), G_WCS) + + # Choose two other graphics wcs' for internal use. Save the wcs for + # later restoration. + if( old_wcs < MAX_WCS - 2 ) { + WL_NDC_WCS(wd) = old_wcs + 1 + WL_PLOT_WCS(wd) = WL_NDC_WCS(wd) + 1 + } else { + WL_NDC_WCS(wd) = old_wcs - 1 + WL_PLOT_WCS(wd) = WL_NDC_WCS(wd) - 1 + } + call gseti(WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call ggview(WL_GP(wd), OLD_NDC_VIEW(LEFT), OLD_NDC_VIEW(RIGHT), + OLD_NDC_VIEW(BOTTOM), OLD_NDC_VIEW(TOP)) + call ggwind(WL_GP(wd), OLD_NDC_WIND(LEFT), OLD_NDC_WIND(RIGHT), + OLD_NDC_WIND(BOTTOM), OLD_NDC_WIND(TOP)) + call gseti(WL_GP(wd), G_WCS, WL_PLOT_WCS(wd)) + call ggview(WL_GP(wd), OLD_PLT_VIEW(LEFT), OLD_PLT_VIEW(RIGHT), + OLD_PLT_VIEW(BOTTOM), OLD_PLT_VIEW(TOP)) + call ggwind(WL_GP(wd), OLD_PLT_WIND(LEFT), OLD_PLT_WIND(RIGHT), + OLD_PLT_WIND(BOTTOM), OLD_PLT_WIND(TOP)) + + # Set the graphics device the way wcslab requires it. + call gseti (WL_GP(wd), G_WCS, old_wcs) + call wl_graphics (wd) + + # Determine basic characteristics of the plot. + call wl_setup (wd) + + # Plot the grid lines. + call wl_grid (wd) + + # Put the grid labels on the lines. + if (WL_LABON(wd) == YES) + call wl_label (wd) + + # Restore the original graphics wcs. + call gseti(WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call gsview(WL_GP(wd), OLD_NDC_VIEW(LEFT), OLD_NDC_VIEW(RIGHT), + OLD_NDC_VIEW(BOTTOM), OLD_NDC_VIEW(TOP)) + call gswind(WL_GP(wd), OLD_NDC_WIND(LEFT), OLD_NDC_WIND(RIGHT), + OLD_NDC_WIND(BOTTOM), OLD_NDC_WIND(TOP)) + call gseti(WL_GP(wd), G_WCS, WL_PLOT_WCS(wd)) + call gsview(WL_GP(wd), OLD_PLT_VIEW(LEFT), OLD_PLT_VIEW(RIGHT), + OLD_PLT_VIEW(BOTTOM), OLD_PLT_VIEW(TOP)) + call gswind(WL_GP(wd), OLD_PLT_WIND(LEFT), OLD_PLT_WIND(RIGHT), + OLD_PLT_WIND(BOTTOM), OLD_PLT_WIND(TOP)) + + # Restore original graphics state. + call gsetr (WL_GP(wd), G_PLWIDTH, old_plwidth) + call gsetr (WL_GP(wd), G_TXSIZE, old_txsize) + call gsetr (WL_GP(wd), G_TXUP, old_txup) + call gseti (WL_GP(wd), G_CLIP, old_clip) + call gseti (WL_GP(wd), G_PLTYPE, old_pltype) + call gseti (WL_GP(wd), G_TXQUALITY, old_txquality) + call gseti (WL_GP(wd), G_WCS, old_wcs) + + call sfree (sp) +end + + +# WL_GRAPHICS -- Setup the graphics device appropriate for the occasion. + +procedure wl_graphics (wd) + +pointer wd # I: the WCSLAB descriptor + +real relative_size, vl, vr, vb, vt +real ggetr() + +begin + # Setup a graphics WCS that mimics the NDC coordinate WCS, + # but with clipping. + call ggview (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_WCS, WL_NDC_WCS(wd)) + call gsview (WL_GP(wd), vl, vr, vb, vt) + call gswind (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_CLIP, YES) + + # Setup the initial viewport. + WL_NEW_VIEW(wd,LEFT) = vl + WL_NEW_VIEW(wd,RIGHT) = vr + WL_NEW_VIEW(wd,BOTTOM) = vb + WL_NEW_VIEW(wd,TOP) = vt + + # Setup some parameters. + call gseti (WL_GP(wd), G_PLTYPE, GL_SOLID) + call gsetr (WL_GP(wd), G_PLWIDTH, LINE_SIZE) + + # Draw the edges of the viewport. + call gamove (WL_GP(wd), vl, vb) + call gadraw (WL_GP(wd), vr, vb) + call gadraw (WL_GP(wd), vr, vt) + call gadraw (WL_GP(wd), vl, vt) + call gadraw (WL_GP(wd), vl, vb) + + # Determine the tick mark size. + relative_size = max (abs (vr - vl), abs (vt - vb )) + WL_MAJ_TICK_SIZE(wd) = relative_size * WL_MAJ_TICK_SIZE(wd) + WL_MIN_TICK_SIZE(wd) = relative_size * WL_MIN_TICK_SIZE(wd) + + # Determine various character sizes. + WL_TITLE_SIZE(wd) = WL_TITLE_SIZE(wd) * relative_size + WL_AXIS_TITLE_SIZE(wd) = WL_AXIS_TITLE_SIZE(wd) * relative_size + WL_LABEL_SIZE(wd) = WL_LABEL_SIZE(wd) * relative_size + + # Now setup the general plotting WCS. + call gseti (WL_GP(wd), G_WCS, WL_PLOT_WCS(WD)) + call gsview (WL_GP(wd), vl, vr, vb, vt) + vl = real (WL_SCREEN_BOUNDARY(wd,LEFT)) + vr = real (WL_SCREEN_BOUNDARY(wd,RIGHT)) + vb = real (WL_SCREEN_BOUNDARY(wd,BOTTOM)) + vt = real (WL_SCREEN_BOUNDARY(wd,TOP)) + call gswind (WL_GP(wd), vl, vr, vb, vt) + call gseti (WL_GP(wd), G_CLIP, YES) + + # Set some characteristics of the graphics device. + call gseti (WL_GP(wd), G_TXQUALITY, GT_HIGH) + call gseti (WL_GP(wd), G_CLIP, YES) + call gsetr (WL_GP(wd), G_PLWIDTH, LINE_SIZE) + + # Determine the number of segments a "line" should consist of. + WL_LINE_SEGMENTS(wd) = int (min (ggetr (WL_GP(wd), "xr"), + ggetr (WL_GP(wd), "yr")) / 5) +end diff --git a/pkg/images/tv/wcslab/zz.x b/pkg/images/tv/wcslab/zz.x new file mode 100644 index 00000000..e6d0224f --- /dev/null +++ b/pkg/images/tv/wcslab/zz.x @@ -0,0 +1,23 @@ +include +include + + +# Define the offset array. +define OFFSET Memr[$1+$2-1] + +procedure wl_label (wd) + +pointer wd # I: the WCSLAB descriptor + +int i +pointer sp, offset_ptr + +begin + # Get some memory. + call smark (sp) + call salloc (offset_ptr, N_SIDES, TY_REAL) + do i = 1, N_SIDES + OFFSET(offset_ptr,i) = 0. + + call sfree (sp) +end diff --git a/pkg/images/tv/wcspars.par b/pkg/images/tv/wcspars.par new file mode 100644 index 00000000..c4ed61d3 --- /dev/null +++ b/pkg/images/tv/wcspars.par @@ -0,0 +1,19 @@ +# WCSPARS pset for WCSLAB containing user WCS + +ctype1,s,h,"linear",,,"X axis type" +ctype2,s,h,"linear",,,"Y axis type" + +crpix1,r,h,0.,,,"X reference coordinate in the logical system" +crpix2,r,h,0.,,,"Y reference coordinate in the logical system" +crval1,r,h,0.,,,"X reference coordinate in the world system" +crval2,r,h,0.,,,"Y reference coordinate in the world system" + +cd1_1,r,h,1.,,,"CD matrix" +cd1_2,r,h,0.,,,"CD matrix" +cd2_1,r,h,0.,,,"CD matrix" +cd2_2,r,h,1.,,,"CD matrix" + +log_x1,r,h,0.,,,"The lower X-extent of the logical space" +log_x2,r,h,1.,,,"The upper X-extent of the logical space" +log_y1,r,h,0.,,,"The lower Y-extent of the logical space" +log_y2,r,h,1.,,,"The upper Y-extent of the logical space" diff --git a/pkg/images/tv/wlpars.par b/pkg/images/tv/wlpars.par new file mode 100644 index 00000000..35bf757b --- /dev/null +++ b/pkg/images/tv/wlpars.par @@ -0,0 +1,45 @@ +# WLPARS pset containing plotting parameters for WCSLAB + +major_grid,b,h,yes,,,"Plot major grid lines instead of tick marks ?" +minor_grid,b,h,no,,,"Plot minor grid lines instead of tick marks ?" +dolabel,b,h,yes,,,"Label major grid lines / tick marks?" +remember,b,h,no,,,"Update wlpars after the plot ?" + +axis1_beg,s,h,"",,,"First major axis 1 value to plot" +axis1_end,s,h,"",,,"Final major axis 1 value to plot" +axis1_int,s,h,"",,,"Axis 1 interval to plot" +axis2_beg,s,h,"",,,"First major axis 2 value to plot" +axis2_end,s,h,"",,,"Final major axis 2 value to plot" +axis2_int,s,h,"",,,"Axis 2 interval to plot" +major_line,s,h,"solid","solid|dotted|dashed|dotdash",,"Major grid line type" +major_tick,r,h,.03,0.,1.,"Major tick size in percent of screen" + +axis1_minor,i,h,5,,,"Number of minor ticks for axis 1" +axis2_minor,i,h,5,,,"Number of minor ticks for axis 2" +minor_line,s,h,"dotted","solid|dotted|dashed|dotdash",,\ + "Line type (solid|dotted|dashed|dotdash)" +minor_tick,r,h,.01,0.,1.,"Minor tick size (percent of screen)" +tick_in,b,h,yes,,,"Should tick marks point into the graph ?" + +axis1_side,s,h,"default",,,"Axis 1 label side" +axis2_side,s,h,"default",,,"Axis 2 label side" +axis2_dir,s,h,"",,,"Axis 1 value at which to label axis 2 (polar)" +justify,s,h,"default","top|bottom|left|right|default",,\ + "Axis 2 side at which to label axis 2 (polar)" +labout,b,h,yes,,,"Draw labels outside axes ?" +rotate,b,h,yes,,,"Allow labels to rotate ?" +full_label,b,h,no,,,"Draw full format labels ?" +label_size,r,h,1.,0.,,"Axis label size" + +title,s,h,"imtitle",,,"Graph title" +axis1_title,s,h,"",,,"Axis 1 title" +axis2_title,s,h,"",,,"Axis 2 title" +title_side,s,h,"top","top|bottom|left|right",,"Title side" +axis1_title_side,s,h,"default","top|bottom|left|right|default",,\ + "Axis 1 title side" +axis2_title_side,s,h,"default","top|bottom|left|right|default",,\ + "Axis 2 title side" +title_size,r,h,1.,0.,,"Title size" +axis_title_size,r,h,1.0,0.,,"Size of the axes titles" + +graph_type,s,h,"default","normal|polar|near_polar|default",,"Graph type" diff --git a/pkg/images/tv/x_tv.x b/pkg/images/tv/x_tv.x new file mode 100644 index 00000000..e4ae5ead --- /dev/null +++ b/pkg/images/tv/x_tv.x @@ -0,0 +1,10 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Display process. + +task display = t_display, + dcontrol = t_dcontrol, + imedit = t_imedit, + imexamine = t_imexamine, + tvmark = t_tvmark, + wcslab = t_wcslab diff --git a/pkg/images/x_images.x b/pkg/images/x_images.x new file mode 100644 index 00000000..455b335f --- /dev/null +++ b/pkg/images/x_images.x @@ -0,0 +1,80 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Images package process. + +task blkavg = t_blkavg, + blkrep = t_blkrep, + boxcar = t_boxcar, + ccfind = t_ccfind, + ccget = t_ccget, + ccmap = t_ccmap, + ccsetwcs = t_ccsetwcs, + ccstd = t_ccstd, + cctran = t_cctran, + ccxymatch = t_ccxymatch, + chpixtype = t_chpixtype, + convolve = t_convolve, + fit1d = t_fit1d, + fmedian = t_fmedian, + fmode = t_fmode, + frmedian = t_frmedian, + frmode = t_frmode, + gauss = t_gauss, + geomap = t_geomap, + geotran = t_geotran, + geoxytran = t_geoxytran, + gradient = t_gradient, + hedit = t_hedit, + hpctran = t_hpctran, + hselect = t_hselect, + imarith = t_imarith, + imaxes = t_imaxes, + imcctran = t_imcctran, + imcentroid = t_imcentroid, + imcombine = t_imcombine, + imcopy = t_imcopy, + imdelete = t_imdelete, + imdivide = t_imdivide, + imexpr = t_imexpr, + imfunction = t_imfunction, + imgets = t_imgets, + imheader = t_imheader, + imhistogram = t_imhistogram, + imjoin = t_imjoin, + imrename = t_imrename, + imreplace = t_imrep, + imshift = t_imshift, + imslice = t_imslice, + imstack = t_imstack, + imstatistics = t_imstatistics, + imsum = t_imsum, + imsurfit = t_imsurfit, + imtile = t_imtile, + imtranspose = t_imtranspose, + im3dtran = t_im3dtran, + laplace = t_laplace, + linmatch = t_linmatch, + lineclean = t_lineclean, + listpixels = t_listpixels, + magnify = t_magnify, + median = t_median, + minmax = t_minmax, + mode = t_mode, + nhedit = t_nhedit, + psfmatch = t_psfmatch, + rmedian = t_rmedian, + rmode = t_rmode, + runmed = t_runmed, + sections = t_sections, + shiftlines = t_shiftlines, + skyctran = t_skyctran, + skyxymatch = t_skyxymatch, + starfind = t_starfind, + wcscopy = t_wcscopy, + wcsctran = t_wcsctran, + wcsedit = t_wcsedit, + wcsreset = t_wcsreset, + wcsxymatch = t_wcsxymatch, + xregister = t_xregister, + xyxymatch = t_xyxymatch + -- cgit